scsh-conservatory
/
commander-s
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

use an object-oriented approach for the plugins. deleted a lot of 

cruft.  broke some plugins (such as browse-directory-list.scm)
This commit is contained in:
eknauel 2005-05-30 19:19:36 +00:00
parent 54230412f8
commit 345712d2da
6 changed files with 151 additions and 396 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

281
scheme/nuit-engine.scm
View File

@ -116,12 +116,11 @@
*current-history-item*) *current-history-item*)
(define-record-type history-entry :history-entry (define-record-type history-entry :history-entry
(make-history-entry command args result plugin) (make-history-entry command args viewer)
history-entry? history-entry?
(command history-entry-command) (command history-entry-command)
(args history-entry-args) (args history-entry-args)
(result history-entry-result set-history-entry-result!) (viewer history-entry-viewer set-history-entry-viewer!))
(plugin history-entry-plugin))
(define (current-history-entry-selector-maker selector) (define (current-history-entry-selector-maker selector)
(lambda () (lambda ()
@ -137,14 +136,14 @@
(define active-command-arguments (define active-command-arguments
(current-history-entry-selector-maker history-entry-args)) (current-history-entry-selector-maker history-entry-args))
(define current-result (define current-viewer
(current-history-entry-selector-maker history-entry-result)) (current-history-entry-selector-maker history-entry-viewer))
(define (update-current-result! new-value) (define (update-current-viewer! new-viewer)
(cond (cond
((current-history-item) ((current-history-item)
=> (lambda (entry) => (lambda (entry)
(set-history-entry-result! (entry-data entry) new-value))) (set-history-entry-viewer! (entry-data entry) new-viewer)))
(else (values)))) (else (values))))
(define (append-to-history! history-entry) (define (append-to-history! history-entry)
@ -244,40 +243,35 @@
(let* ((tokens (split-command-line command-line)) (let* ((tokens (split-command-line command-line))
(command (car tokens)) (command (car tokens))
(args (cdr tokens)) (args (cdr tokens))
(command-plugin (find-command-plugin command))) (command-plugin (find-command-plugin command))
(call-with-values (viewer
(lambda () (find/init-plugin-for-result
(find/init-plugin-for-result (with-errno-handler
(with-errno-handler ((errno data)
((errno data) (else data))
(else data)) ((command-plugin-evaluater command-plugin) command args))))
((command-plugin-evaluater command-plugin) command args)))) (new-entry
(lambda (result plugin) (make-history-entry command args viewer)))
(let ((new-entry ;; FIXME, use insert here
(make-history-entry command args (append-to-history! new-entry)
result plugin))) (buffer-text-append-new-line! command-buffer)
;; FIXME, use insert here (paint-result/command-buffer new-entry)))
(append-to-history! new-entry)
(buffer-text-append-new-line! command-buffer)
(paint-result/command-buffer new-entry))))))
(define (eval-command-in-scheme-mode command-line) (define (eval-command-in-scheme-mode command-line)
(call-with-values (let ((viewer
(lambda () (find/init-plugin-for-result
(find/init-plugin-for-result (eval-expression command-line))))
(eval-expression command-line))) (let* ((tokens (split-command-line command-line))
(lambda (result plugin) (command (car tokens))
(let* ((tokens (split-command-line command-line)) (args (cdr tokens))
(command (car tokens)) (new-entry
(args (cdr tokens)) (make-history-entry command args viewer)))
(new-entry ;; #### shouldn't we use some kind of insertion here?
(make-history-entry command args (append-to-history! new-entry)
result plugin))) (buffer-text-append-new-line! command-buffer)
;; FIXME, use insert here (paint-result/command-buffer new-entry))))
(append-to-history! new-entry)
(buffer-text-append-new-line! command-buffer)
(paint-result/command-buffer new-entry)))))
;; #### crufty
(define split-command-line string-tokenize) (define split-command-line string-tokenize)
;; handle input ;; handle input
@ -295,7 +289,6 @@
(let loop ((ch (wait-for-input)) (c-x-pressed? #f) (let loop ((ch (wait-for-input)) (c-x-pressed? #f)
(completion-selector #f)) (completion-selector #f))
(debug-message "loop: " ch "|" c-x-pressed? "|" completion-selector)
(cond (cond
;; Ctrl-x -> wait for next input ;; Ctrl-x -> wait for next input
@ -341,22 +334,14 @@
(current-history-item) (current-history-item)
(= ch 112)) (= ch 112))
(add-string-to-command-buffer (add-string-to-command-buffer
(post-message (send (current-viewer) 'get-selection))
(history-entry-plugin (entry-data (current-history-item)))
(make-selection-message (active-command) (current-result))))
(loop (wait-for-input) #f #f)) (loop (wait-for-input) #f #f))
((and c-x-pressed? (focus-on-result-buffer?)) ((and c-x-pressed? (focus-on-result-buffer?))
(let ((key-message (update-current-viewer!
(make-key-pressed-message (send (current-viewer)
(active-command) (current-result) 'key-press ch key-control-x))
result-buffer (loop (wait-for-input) #f #f))
ch key-control-x)))
(update-current-result!
(post-message
(history-entry-plugin (entry-data (current-history-item)))
key-message))
(loop (wait-for-input) #f #f)))
;; C-x r --- redo ;; C-x r --- redo
((and c-x-pressed? (focus-on-command-buffer?) ((and c-x-pressed? (focus-on-command-buffer?)
@ -396,13 +381,9 @@
(cond (cond
((focus-on-result-buffer?) ((focus-on-result-buffer?)
(when (current-history-item) (when (current-history-item)
(update-current-result! (update-current-viewer!
(post-message (send (current-viewer)
(history-entry-plugin (entry-data (current-history-item))) 'key-press ch c-x-pressed?))
(make-key-pressed-message
(active-command) (current-result)
result-buffer
ch c-x-pressed?)))
(paint-result-window (entry-data (current-history-item))) (paint-result-window (entry-data (current-history-item)))
(move-cursor command-buffer result-buffer) (move-cursor command-buffer result-buffer)
(refresh-result-window)) (refresh-result-window))
@ -536,13 +517,10 @@
(wrefresh win))) (wrefresh win)))
(define (paint-result-window entry) (define (paint-result-window entry)
(wclear (app-window-curses-win result-window)) (let ((win (app-window-curses-win result-window)))
(paint-result-buffer (wclear win)
(post-message (send (history-entry-viewer entry)
(history-entry-plugin entry) 'paint win result-buffer (focus-on-result-buffer?))))
(make-print-message (history-entry-command entry)
(history-entry-result entry)
(buffer-num-cols command-buffer)))))
(define (refresh-result-window) (define (refresh-result-window)
(wrefresh (app-window-curses-win result-window))) (wrefresh (app-window-curses-win result-window)))
@ -578,75 +556,12 @@
(define (find/init-plugin-for-result result) (define (find/init-plugin-for-result result)
(cond (cond
((determine-plugin-by-type result) ((determine-plugin-by-type result)
=> (lambda (plugin) => (lambda (view-plugin)
(values (let ((instance ((view-plugin-constructor view-plugin))))
(post-message plugin (send instance 'init result result-buffer))))
(make-init-with-result-message
result result-buffer))
plugin)))
(else (else
(values (let ((instance (make-standard-viewer)))
(post-message standard-view-plugin (send instance 'init result result-buffer)))))
(make-init-with-result-message
result result-buffer))
standard-view-plugin))))
;;Extracts the name of the function and its parameters
(define extract-com-and-par
(lambda (com)
(if (<= (string-length com) 0)
(cons "" '())
(if (equal? #\( (string-ref com 0))
(cons com '())
(let* ((fst-word (get-next-word com))
(command (car fst-word))
(rest (cdr fst-word)))
(let loop ((param-str rest)
(param-list '()))
(let* ((word (get-next-word param-str))
(param (car word))
(more (cdr word)))
(if (equal? "" param)
(cons command param-list)
(loop more (append param-list (list param)))))))))))
;;gets the next word from a string
(define (get-next-word str)
(let loop ((old str)
(new ""))
(if (= 0 (string-length old))
(cons new old)
(if (char=? #\space (string-ref old 0))
(if (= 1 (string-length old))
(cons new "")
(cons new (substring old 1 (string-length old))))
(if (char=? #\( (string-ref old 0))
(let* ((nw (get-next-word-braces
(substring old 1
(string-length old))))
(nw-new (car nw))
(nw-old (cdr nw)))
(loop nw-old (string-append new "(" nw-new)))
(loop (substring old 1 (string-length old))
(string-append new (string (string-ref old 0)))))))))
(define (get-next-word-braces str)
(let loop ((old str)
(new ""))
(if (= 0 (string-length old))
(cons new old)
(if (char=? #\( (string-ref old 0))
(let* ((nw (get-next-word-braces
(substring old 1
(string-length old))))
(nw-new (car nw))
(nw-old (cdr nw)))
(loop nw-old (string-append new "(" nw-new)))
(if (char=? #\) (string-ref old 0))
(cons (string-append new ")")
(substring old 1 (string-length old)))
(loop (substring old 1 (string-length old))
(string-append new (string (string-ref old 0)))))))))
;;scroll buffer after one command was entered ;;scroll buffer after one command was entered
(define (scroll-command-buffer) (define (scroll-command-buffer)
@ -672,14 +587,6 @@
(lambda () (lambda ()
(eval (read-sexp-from-string exp) env)))))) (eval (read-sexp-from-string exp) env))))))
(define (post-message plugin message)
(cond
((view-plugin? plugin)
((view-plugin-fun plugin) message))
(else
(error "don't know how to talk to this plugin type"
plugin))))
(define (determine-plugin-by-type result) (define (determine-plugin-by-type result)
(find (lambda (r) (find (lambda (r)
((view-plugin-type-predicate r) result)) ((view-plugin-type-predicate r) result))
@ -734,13 +641,6 @@
(history-entry-command (entry-data entry)) width))))) (history-entry-command (entry-data entry)) width)))))
(wrefresh win))) (wrefresh win)))
(define (paint-result-buffer paint-proc)
(debug-message "paint-result-buffer before")
(paint-proc (app-window-curses-win result-window)
result-buffer
(focus-on-result-buffer?))
(debug-message "paint-result-buffer after"))
;;Cursor ;;Cursor
;;move cursor to the corrct position ;;move cursor to the corrct position
(define (move-cursor command-buffer result-buffer) (define (move-cursor command-buffer result-buffer)
@ -890,7 +790,8 @@
(mvwaddstr win 0 0 (mvwaddstr win 0 0
(string-append "Possible completions for " command)) (string-append "Possible completions for " command))
(wattrset win (A-NORMAL)) (wattrset win (A-NORMAL))
(paint-result-buffer (paint-selection-list-at select-list 0 2)) ((paint-selection-list-at select-list 0 2)
win result-buffer (focus-on-result-buffer?))
(refresh-result-window))) (refresh-result-window)))
;; #### implement me ;; #### implement me
@ -960,11 +861,7 @@
((or (select-list-navigation-key? key) ((or (select-list-navigation-key? key)
(select-list-marking-key? key)) (select-list-marking-key? key))
(let ((new-select-list (let ((new-select-list
(select-list-handle-key-press (select-list-handle-key-press select-list key)))
select-list
(make-key-pressed-message
(active-command) (current-result)
result-buffer key #f))))
(paint-completion-select-list (paint-completion-select-list
new-select-list (last (buffer-text command-buffer))) new-select-list (last (buffer-text command-buffer)))
(make-completion-selector (make-completion-selector
@ -1016,56 +913,34 @@
(lp (cdr chars) (string-append token (string (car chars))) (lp (cdr chars) (string-append token (string (car chars)))
tokens (+ i 1))))))) tokens (+ i 1)))))))
(define-record-type standard-result-obj standard-result-obj (define (make-standard-viewer)
(make-standard-result-obj cursor-pos-y (let ((x 1)
cursor-pos-x (y 1)
result-text (text "")
result) (value #f))
standard-result-obj?
(cursor-pos-y standard-result-obj-cur-pos-y)
(cursor-pos-x standard-result-obj-cur-pos-x)
(result-text standard-result-obj-result-text)
(result standard-result-obj-result))
(define init-std-res (lambda (message)
(make-standard-result-obj 1 1 '("") "")) (cond
;;Standard-Receiver: ((eq? message 'init)
(define (standard-receiver-rec message) (lambda (self new-value buffer)
(cond (set! value new-value)
((init-with-result-message? message) (set! text
(make-standard-result-obj (layout-result-standard
1 1 (exp->string value)
(layout-result-standard (result-buffer-num-cols buffer)))
(exp->string (init-with-result-message-result message)) self))
(result-buffer-num-cols
(init-with-result-message-buffer message))) ((eq? message 'paint)
(init-with-result-message-result message))) (lambda (self win buffer have-focus?)
((next-command-message? message) ;; #### get rid of this cruft
(let* ((result (eval-expression (message-command-string message))) ((make-simple-result-buffer-printer y x text '() '())
(result-string (exp->string result)) win buffer have-focus?)))
(width (next-command-message-width message))
(text (layout-result-standard result-string width))
(std-obj (make-standard-result-obj 1 1 text result)))
std-obj))
((print-message? message)
(let* ((model (message-result-object message))
(pos-y (standard-result-obj-cur-pos-y model))
(pos-x (standard-result-obj-cur-pos-x model))
(width (print-message-width message))
(result (standard-result-obj-result model))
(text (layout-result-standard
(exp->string result) width)))
(make-simple-result-buffer-printer
pos-y pos-x text '() '())))
((key-pressed-message? message)
(message-result-object message))
((restore-message? message)
(values))
((selection-message? message)
"")))
((eq? message 'key)
(lambda (self . ignore)
self))))))
(define standard-view-plugin (define standard-view-plugin
(make-view-plugin standard-receiver-rec (make-view-plugin make-standard-viewer
(lambda (val) #t))) (lambda (val) #t)))

59
scheme/nuit-packages.scm
View File

@ -70,13 +70,14 @@
;;; process viewer plugin ;;; process viewer plugin
(define-structure process-view-plugin (define-structure process-viewer
(export) (export)
(open scheme (open scheme
define-record-types define-record-types
srfi-1 srfi-1
srfi-13 srfi-13
formats formats
signals
pps pps
plugin plugin
@ -214,7 +215,7 @@
(define-interface plugin-interface (define-interface plugin-interface
(export make-view-plugin (export make-view-plugin
view-plugin? view-plugin?
view-plugin-fun view-plugin-constructor
view-plugin-type-predicate view-plugin-type-predicate
make-command-plugin make-command-plugin
@ -223,49 +224,12 @@
command-plugin-completer command-plugin-completer
command-plugin-evaluater command-plugin-evaluater
register-plugin! register-plugin!))
next-command-message?
next-command-string
next-command-message-parameters
next-command-message-width
init-with-result-message?
init-with-result-message-result
init-with-result-message-buffer
key-pressed-message?
key-pressed-message-result-buffer
key-pressed-message-result-object
key-pressed-message-key
key-pressed-message-prefix-key
print-message?
print-message-command-string
print-message-result-object
print-message-width
restore-message?
restore-message-command-string
restore-message-result-object
selection-message?
selection-message-command-string
selection-message-result-object
message-result-object
message-command-string))
(define-interface plugin-host-interface (define-interface plugin-host-interface
(export command-plugin-list (export command-plugin-list
view-plugin-list view-plugin-list
command-completions command-completions))
make-next-command-message
make-init-with-result-message
make-key-pressed-message
make-print-message
make-restore-message
make-selection-message))
(define-structures (define-structures
((plugin plugin-interface) ((plugin plugin-interface)
@ -278,6 +242,16 @@
completion-sets) completion-sets)
(files plugins)) (files plugins))
;;; objects
(define-interface objects-interface
(export send))
(define-structure objects objects-interface
(open scheme
signals)
(files objects))
;;; focus table ;;; focus table
; (define-interface focus-table-interface ; (define-interface focus-table-interface
@ -332,6 +306,7 @@
rt-modules rt-modules
tty-debug tty-debug
fs-object fs-object
objects
plugin plugin
plugin-host plugin-host
layout layout
@ -342,7 +317,7 @@
select-list select-list
;; the following modules are plugins ;; the following modules are plugins
dirlist-view-plugin dirlist-view-plugin
process-view-plugin process-viewer
standard-command-plugin standard-command-plugin
nuit-inspector-plugin) nuit-inspector-plugin)
(files nuit-engine)) (files nuit-engine))

11
scheme/objects.scm Normal file
View File

@ -0,0 +1,11 @@
(define (get-method object message)
(object message))
(define method? procedure?)
(define (send object message . args)
(let ((method (get-method object message)))
(if (method? method)
(apply method (cons object args))
(error "No method" message))))

92
scheme/plugins.scm
View File

@ -15,9 +15,9 @@
*command-completions*) *command-completions*)
(define-record-type view-plugin :view-plugin (define-record-type view-plugin :view-plugin
(make-view-plugin fun type-predicate) (make-view-plugin constructor type-predicate)
view-plugin? view-plugin?
(fun view-plugin-fun) (constructor view-plugin-constructor)
(type-predicate view-plugin-type-predicate)) (type-predicate view-plugin-type-predicate))
(define-record-type command-plugin :command-plugin (define-record-type command-plugin :command-plugin
@ -38,91 +38,3 @@
(set! *view-plugins* (cons plugin *view-plugins*))) (set! *view-plugins* (cons plugin *view-plugins*)))
(error "unknown plugin type" plugin))) (error "unknown plugin type" plugin)))
;; messages
(define-record-type next-command-message :next-command-message
(make-next-command-message command-string
parameters
width)
next-command-message?
(command-string next-command-string)
(parameters next-command-message-parameters)
(width next-command-message-width))
(define-record-type init-with-result-message :init-with-result-message
(make-init-with-result-message result buffer)
init-with-result-message?
(result init-with-result-message-result)
(buffer init-with-result-message-buffer))
;;key pressed
;;The object and the key are send to the user-code, who returns the
;;changed object.
(define-record-type key-pressed-message :key-pressed-message
(make-key-pressed-message command-string
result-object
result-buffer
key prefix-key)
key-pressed-message?
(command-string key-pressed-command-string)
(result-object key-pressed-message-result-object)
(result-buffer key-pressed-message-result-buffer)
(key key-pressed-message-key)
(prefix-key key-pressed-message-prefix-key))
;;print
(define-record-type print-message :print-message
(make-print-message command-string
result-object
width)
print-message?
(command-string print-message-command-string)
(result-object print-message-result-object)
(width print-message-width))
;;restore (when side-effects occur)
(define-record-type restore-message :restore-message
(make-restore-message command-string
result-object)
restore-message?
(command-string restore-message-command-string)
(result-object restore-message-result-object))
;;request the selection
(define-record-type selection-message :selection-message
(make-selection-message command-string
result-object)
selection-message?
(command-string selection-message-command-string)
(result-object selection-message-result-object))
(define (message-result-object message)
((cond
((key-pressed-message? message)
key-pressed-message-result-object)
((print-message? message)
print-message-result-object)
((restore-message? message)
restore-message-result-object)
((selection-message? message)
selection-message-result-object)
(else
(error "This message-type has no field for result-objects"
message)))
message))
(define (message-command-string message)
((cond
((next-command-message? message)
next-command-string)
((key-pressed-message? message)
key-pressed-command-string)
((print-message? message)
print-message-command-string)
((restore-message? message)
restore-message-command-string)
((selection-message? message)
selection-message-command-string)
(else
(error "This message-type has no command field" message)))
message))

68
scheme/process.scm
View File

@ -1,14 +1,3 @@
(define-record-type plugin-state :plugin-state
(make-plugin-state processes selection-list cursor-x)
plugin-state?
(processes plugin-state-processes)
(selection-list plugin-state-selection-list)
(cursor-x plugin-state-cursor-x))
(define-record-discloser :plugin-state
(lambda (r)
`(plugin-state ,(plugin-state-selection-list r))))
(define (list-of-processes? thing) (define (list-of-processes? thing)
(and (proper-list? thing) (and (proper-list? thing)
(every process-info? thing))) (every process-info? thing)))
@ -41,38 +30,35 @@
processes) processes)
num-lines))) num-lines)))
(define (pps-receiver message) (define (make-pps-viewer)
(debug-message "pps-receiver " message) (let ((processes #f)
(cond (select-list #f))
(lambda (message)
(cond
((init-with-result-message? message) ((eq? message 'init)
(let* ((processes (init-with-result-message-result message)) (lambda (self process-list buffer)
(buffer (init-with-result-message-buffer message)) (let ((num-cols (result-buffer-num-cols buffer))
(num-cols (result-buffer-num-cols buffer)) (num-lines (result-buffer-num-lines buffer)))
(num-lines (result-buffer-num-lines buffer))) (set! processes process-list)
(make-plugin-state (set! select-list
processes (make-process-selection-list
(make-process-selection-list num-cols num-lines processes) 1))) num-cols num-lines processes))
self)))
((print-message? message) ((eq? message 'paint)
(paint-selection-list (lambda (self . args)
(plugin-state-selection-list (apply paint-selection-list
(message-result-object message)))) (cons select-list args))))
((key-pressed-message? message) ((eq? message 'key-press)
(let ((old-state (message-result-object message))) (lambda (self key control-x-pressed?)
(make-plugin-state (set! select-list
(plugin-state-processes old-state) (select-list-handle-key-press select-list key))
(select-list-handle-key-press self))
(plugin-state-selection-list old-state)
message) (else
(plugin-state-cursor-x old-state)))) (error "pps-viewer unknown message" message))))))
((restore-message? message)
(values))
((selection-message? message)
"'()")))
(register-plugin! (register-plugin!
(make-view-plugin pps-receiver list-of-processes?)) (make-view-plugin make-pps-viewer list-of-processes?))

36
scheme/select-list.scm
View File

@ -37,21 +37,18 @@
(define key-u 117) (define key-u 117)
(define (select-list-handle-key-press select-list key-message) (define (select-list-handle-key-press select-list key)
(let ((key (key-pressed-message-key key-message)) (cond
(result-buffer (key-pressed-message-result-buffer key-message))) ((= key key-m)
(debug-message "select-list-handle-key-press " select-list " " key) (mark-current-line select-list))
(cond ((= key key-u)
((= key key-m) (unmark-current-line select-list))
(mark-current-line select-list)) ((= key key-up)
((= key key-u) (move-cursor-up select-list))
(unmark-current-line select-list)) ((= key key-down)
((= key key-up) (move-cursor-down select-list))
(move-cursor-up select-list)) (else
((= key key-down) select-list)))
(move-cursor-down select-list))
(else
select-list))))
(define (select-list-navigation-key? key) (define (select-list-navigation-key? key)
(or (= key key-up) (= key key-down))) (or (= key key-up) (= key key-down)))
@ -142,11 +139,10 @@
(select-list-view-index select-list)) (select-list-view-index select-list))
(+ 1 num-lines))) (+ 1 num-lines)))
(define (paint-selection-list select-list) (define (paint-selection-list select-list win result-buffer have-focus?)
(paint-selection-list-at select-list 0 0)) (paint-selection-list-at select-list 0 0 win result-buffer have-focus?))
(define (paint-selection-list-at select-list x y) (define (paint-selection-list-at select-list x y win result-buffer have-focus?)
(lambda (win result-buffer have-focus?)
(let ((num-lines (select-list-num-lines select-list))) (let ((num-lines (select-list-num-lines select-list)))
(let lp ((elts (let lp ((elts
(select-visible-elements select-list num-lines)) (select-visible-elements select-list num-lines))
@ -167,7 +163,7 @@
(lp (cdr elts) (+ y 1) (+ i 1))) (lp (cdr elts) (+ y 1) (+ i 1)))
(else (else
(mvwaddstr win y x (element-text (car elts))) (mvwaddstr win y x (element-text (car elts)))
(lp (cdr elts) (+ y 1) (+ i 1)))))))) (lp (cdr elts) (+ y 1) (+ i 1)))))))
(define (select-list-get-selection select-list) (define (select-list-get-selection select-list)
(map element-value (map element-value