select the plug-in for viewing a result by it's type. Currently only
works with processes.
This commit is contained in:
eknauel
parent
783bad745a
commit
87f701f59d
|
|
@ -1,5 +1,11 @@
|
|||
;; ,load /home/demattia/studium/studienarbeit/scsh-nuit/scheme/nuit-engine.scm
|
||||
|
||||
(define-syntax when
|
||||
(syntax-rules ()
|
||||
((_ ?test ?do-this ...)
|
||||
(if ?test
|
||||
(begin ?do-this ... (values))
|
||||
(values)))))
|
||||
|
||||
;;This is the "heart" of NUIT.
|
||||
;;In a central loop the program waits for input (with wgetch).
|
||||
|
|
@ -28,7 +34,7 @@
|
|||
(w ,(app-window-width rec)) (h ,(app-window-height rec)))))
|
||||
|
||||
(define bar-1 #f)
|
||||
(define bar-2 #f)
|
||||
(define active-command-window #f)
|
||||
|
||||
(define command-frame-window #f)
|
||||
(define command-window #f)
|
||||
|
|
@ -49,6 +55,9 @@
|
|||
"Ctrl+a:First Pos of Line"
|
||||
"Ctrl+e:End of Line"
|
||||
"Ctrl+k:Delete Line"))
|
||||
|
||||
(define key-control-x 24)
|
||||
(define key-o 111)
|
||||
|
||||
;;state of the upper window (Command-Window)
|
||||
(define command-buffer
|
||||
|
|
@ -106,30 +115,72 @@
|
|||
(define (focus-result-buffer!)
|
||||
(set! *focus-buffer* 'result-buffer))
|
||||
|
||||
;;History
|
||||
(define history '())
|
||||
;; History
|
||||
|
||||
;;Position in the "elaborated" History
|
||||
(define history-pos 0)
|
||||
(define the-history (make-empty-history))
|
||||
|
||||
;;data-type for history.entries
|
||||
(define-record-type history-entry history-entry
|
||||
(make-history-entry command
|
||||
parameters
|
||||
result-object)
|
||||
(define (history) the-history)
|
||||
|
||||
(define *current-history-item* #f)
|
||||
|
||||
(define (current-history-item)
|
||||
*current-history-item*)
|
||||
|
||||
(define-record-type history-entry :history-entry
|
||||
(make-history-entry command args result receiver)
|
||||
history-entry?
|
||||
(command history-entry-command)
|
||||
(parameters history-entry-parameters)
|
||||
(result-object history-entry-result-object))
|
||||
(args history-entry-args)
|
||||
(result history-entry-result set-history-entry-result!)
|
||||
(receiver history-entry-receiver))
|
||||
|
||||
;;active command
|
||||
(define active-command "")
|
||||
(define (current-history-entry-selector-maker selector)
|
||||
(lambda ()
|
||||
(cond
|
||||
((current-history-item)
|
||||
=> (lambda (entry)
|
||||
(selector (entry-data entry))))
|
||||
(else #f))))
|
||||
|
||||
;;sctive parameters
|
||||
(define active-parameters "")
|
||||
(define active-command
|
||||
(current-history-entry-selector-maker history-entry-command))
|
||||
|
||||
;;active result-object
|
||||
(define current-result-object)
|
||||
(define active-command-arguments
|
||||
(current-history-entry-selector-maker history-entry-args))
|
||||
|
||||
(define current-result
|
||||
(current-history-entry-selector-maker history-entry-result))
|
||||
|
||||
(define (update-current-result! new-value)
|
||||
(cond
|
||||
((current-history-item)
|
||||
=> (lambda (entry)
|
||||
(set-history-entry-result! (entry-data) new-value)))
|
||||
(else (values))))
|
||||
|
||||
(define (append-to-history! history-entry)
|
||||
(append-history-item! the-history history-entry)
|
||||
(set! *current-history-item*
|
||||
(history-last-entry the-history)))
|
||||
|
||||
;; one step back in the history
|
||||
(define (history-back!)
|
||||
(cond
|
||||
((and (current-history-item)
|
||||
(history-prev-entry (current-history-item)))
|
||||
=> (lambda (prev)
|
||||
(set! *current-history-item* prev)))
|
||||
(else (values))))
|
||||
|
||||
;; one step forward
|
||||
(define (history-forward!)
|
||||
(cond
|
||||
((and *current-history-item*
|
||||
(history-next-entry *current-history-item*))
|
||||
=> (lambda (next)
|
||||
(set! *current-history-item* next)))
|
||||
(else (values))))
|
||||
|
||||
;;active keyboard-interrupt:
|
||||
;;after each input this is set to #f.
|
||||
|
|
@ -159,11 +210,12 @@
|
|||
(define-record-type key-pressed-message :key-pressed-message
|
||||
(make-key-pressed-message command-string
|
||||
result-object
|
||||
key)
|
||||
key prefix-key)
|
||||
key-pressed-message?
|
||||
(command-string key-pressed-command-string)
|
||||
(result-object key-pressed-message-result-object)
|
||||
(key key-pressed-message-key))
|
||||
(key key-pressed-message-key)
|
||||
(prefix-key key-pressed-message-prefix-key))
|
||||
|
||||
;;print
|
||||
(define-record-type print-message :print-message
|
||||
|
|
@ -182,6 +234,7 @@
|
|||
text
|
||||
highlighted-lines
|
||||
marked-lines)
|
||||
print-object?
|
||||
(pos-y print-object-pos-y)
|
||||
(pos-x print-object-pos-x)
|
||||
(text print-object-text)
|
||||
|
|
@ -239,10 +292,17 @@
|
|||
;;about which function is meant to be the receiver, when a certain
|
||||
;;command is active
|
||||
(define-record-type receiver :receiver
|
||||
(make-receiver command rec)
|
||||
(really-make-receiver command rec type-predicate)
|
||||
receiver?
|
||||
(command receiver-command)
|
||||
(rec receiver-rec))
|
||||
(rec receiver-rec)
|
||||
(type-predicate receiver-type-predicate))
|
||||
|
||||
(define (make-receiver command rec . more)
|
||||
(really-make-receiver command rec
|
||||
(if (null? more)
|
||||
(lambda (v) #f)
|
||||
(car more))))
|
||||
|
||||
;;This list contains all the receivers that have been registered.
|
||||
(define receivers '())
|
||||
|
|
@ -270,7 +330,17 @@
|
|||
#t)))
|
||||
run))
|
||||
|
||||
;;handle input
|
||||
(define (toggle-buffer-focus)
|
||||
(cond
|
||||
((focus-on-command-buffer?)
|
||||
(focus-result-buffer!)
|
||||
(refresh-result-window))
|
||||
(else
|
||||
(focus-command-buffer!)
|
||||
(move-cursor command-buffer)
|
||||
(refresh-command-window))))
|
||||
|
||||
;; handle input
|
||||
(define (run)
|
||||
|
||||
(init-windows!)
|
||||
|
|
@ -280,160 +350,88 @@
|
|||
|
||||
;;Loop
|
||||
(paint)
|
||||
(let loop ((ch (wait-for-input)))
|
||||
(let loop ((ch (wait-for-input)) (c-x-pressed? #f))
|
||||
(cond
|
||||
;;The result of pressing these keys is independent of which
|
||||
;;Buffer is active
|
||||
;;Finish
|
||||
|
||||
;; Ctrl-x -> wait for next input
|
||||
((= ch key-control-x)
|
||||
(loop (wait-for-input) #t))
|
||||
|
||||
;; C-x o --- toggle buffer focus
|
||||
((and c-x-pressed? (= ch key-o))
|
||||
(toggle-buffer-focus)
|
||||
(loop (wait-for-input) #f))
|
||||
|
||||
((and c-x-pressed? (focus-on-result-buffer?))
|
||||
(let ((key-message
|
||||
(make-key-pressed-message
|
||||
(active-command) (current-result)
|
||||
ch key-control-x)))
|
||||
(update-current-result!
|
||||
(post-message
|
||||
(history-entry-receiver (entry-data (current-history-item)))
|
||||
key-message))
|
||||
(loop (wait-for-input) #f)))
|
||||
|
||||
;; C-x r --- redo
|
||||
((and c-x-pressed? (focus-on-command-buffer?)
|
||||
(= ch 114))
|
||||
(debug-message "Eric should re-implement redo..."))
|
||||
|
||||
((= ch key-f1)
|
||||
(begin
|
||||
(let ((restore-message (make-restore-message
|
||||
active-command
|
||||
current-result-object)))
|
||||
(switch restore-message)
|
||||
(restore-state))
|
||||
(endwin)
|
||||
(display "")))
|
||||
(endwin))
|
||||
|
||||
((= ch key-f2)
|
||||
(endwin)
|
||||
(run))
|
||||
|
||||
;;Ctrl-x -> wait for next input
|
||||
((= ch 24)
|
||||
(begin
|
||||
(set! c-x-pressed (not c-x-pressed))
|
||||
(if (focus-on-result-buffer?)
|
||||
(let ((key-message
|
||||
(make-key-pressed-message active-command
|
||||
current-result-object
|
||||
ch)))
|
||||
(set! current-result-object (switch key-message))))
|
||||
(paint)
|
||||
(loop (wait-for-input))))
|
||||
|
||||
((= ch 35)
|
||||
(error "Is this what you want?"))
|
||||
(paint)
|
||||
(loop (wait-for-input) c-x-pressed?))
|
||||
|
||||
;; forward in result history
|
||||
((= ch key-npage)
|
||||
(history-forward)
|
||||
(paint-result-window)
|
||||
(history-forward!)
|
||||
(when (current-history-item)
|
||||
(paint-active-command-window)
|
||||
(paint-result-window (entry-data (current-history-item))))
|
||||
(refresh-result-window)
|
||||
(loop (wait-for-input)))
|
||||
(loop (wait-for-input) c-x-pressed?))
|
||||
|
||||
;; back in result history
|
||||
((= ch key-ppage)
|
||||
(history-back)
|
||||
(paint-result-window)
|
||||
(history-back!)
|
||||
(when (current-history-item)
|
||||
(paint-active-command-window)
|
||||
(paint-result-window (entry-data (current-history-item))))
|
||||
(refresh-result-window)
|
||||
(loop (wait-for-input)))
|
||||
(loop (wait-for-input) c-x-pressed?))
|
||||
|
||||
;;if lower window is active a message is sent.
|
||||
(else
|
||||
(if c-x-pressed
|
||||
(cond
|
||||
|
||||
;;Ctrl-x o ->switch buffer
|
||||
((= ch 111)
|
||||
(if (focus-on-command-buffer?)
|
||||
(let ((key-message
|
||||
(make-key-pressed-message active-command
|
||||
current-result-object
|
||||
97)))
|
||||
(focus-result-buffer!)
|
||||
(set! current-result-object (switch key-message))
|
||||
(paint-result-window)
|
||||
(refresh-result-window))
|
||||
(begin
|
||||
(focus-command-buffer!)
|
||||
(paint-command-window-contents)
|
||||
(move-cursor command-buffer)))
|
||||
(set! c-x-pressed #f)
|
||||
(loop (wait-for-input)))
|
||||
((= ch 10)
|
||||
(let ((command (last (buffer-text command-buffer))))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(execute-command command))
|
||||
(lambda (result receiver)
|
||||
(let ((new-entry
|
||||
(make-history-entry command '()
|
||||
result receiver)))
|
||||
(append-to-history! new-entry)
|
||||
(buffer-text-append-new-line! command-buffer)
|
||||
(paint-result-window new-entry)
|
||||
(paint-active-command-window)
|
||||
(scroll-command-buffer)
|
||||
(paint-command-window-contents)
|
||||
(move-cursor command-buffer)
|
||||
(refresh-result-window)
|
||||
(refresh-command-window)
|
||||
(loop (wait-for-input) c-x-pressed?))))))
|
||||
|
||||
;;C-x r -> redo
|
||||
((= ch 114)
|
||||
(if (or (> (length (buffer-text command-buffer)) 2)
|
||||
(not (equal? active-command "")))
|
||||
(let ((command-string (string-append active-command
|
||||
active-parameters))
|
||||
(text (sublist (buffer-text command-buffer) 0
|
||||
(- (length (buffer-text command-buffer)) 1))))
|
||||
(begin
|
||||
;; is this correct?
|
||||
(switch (make-restore-message
|
||||
command-string
|
||||
current-result-object))
|
||||
(set-buffer-text! (append text (list command-string)))
|
||||
(execute-command)
|
||||
(set-buffer-history-pos! command-buffer
|
||||
(- (length (buffer-text command-buffer)) 1))
|
||||
(set! c-x-pressed #f)
|
||||
(endwin)
|
||||
(run)))
|
||||
(begin
|
||||
(set! c-x-pressed #f)
|
||||
(loop (wait-for-input)))))
|
||||
|
||||
(else
|
||||
(begin
|
||||
(if (focus-on-result-buffer?)
|
||||
(let ((key-message
|
||||
(make-key-pressed-message active-command
|
||||
current-result-object
|
||||
ch)))
|
||||
(set! current-result-object (switch key-message)))
|
||||
|
||||
(if (= ch 115)
|
||||
(let* ((message
|
||||
(make-selection-message
|
||||
active-command current-result-object))
|
||||
(marked-items (switch message)))
|
||||
(add-string-to-command-buffer marked-items))))
|
||||
(set! c-x-pressed #f)
|
||||
(loop (wait-for-input)))))
|
||||
|
||||
(if (focus-on-result-buffer?)
|
||||
(let ((key-message
|
||||
(make-key-pressed-message active-command
|
||||
current-result-object
|
||||
ch)))
|
||||
(set! current-result-object (switch key-message))
|
||||
(paint-result-window)
|
||||
(refresh-result-window)
|
||||
(loop (wait-for-input)))
|
||||
|
||||
(cond
|
||||
|
||||
;;Enter
|
||||
((= ch 10)
|
||||
(let ((restore-message (make-restore-message
|
||||
active-command
|
||||
current-result-object)))
|
||||
(switch restore-message)
|
||||
(execute-command)
|
||||
(set-buffer-history-pos!
|
||||
command-buffer
|
||||
(- (length (buffer-text command-buffer)) 1))
|
||||
(paint-result-window)
|
||||
(refresh-result-window)
|
||||
(paint-bar-2)
|
||||
(paint-command-window-contents)
|
||||
(move-cursor command-buffer)
|
||||
(refresh-command-window)
|
||||
(loop (wait-for-input))))
|
||||
|
||||
(else
|
||||
(input command-buffer ch)
|
||||
;(debug-message "loop after input " command-buffer)
|
||||
(werase (app-window-curses-win command-window))
|
||||
(print-command-buffer (app-window-curses-win command-window)
|
||||
command-buffer)
|
||||
;(debug-message "loop after print-command-buffer " command-buffer)
|
||||
(move-cursor command-buffer)
|
||||
(refresh-command-window)
|
||||
(loop (wait-for-input))))))))))
|
||||
(else
|
||||
(input command-buffer ch)
|
||||
(werase (app-window-curses-win command-window))
|
||||
(print-command-buffer (app-window-curses-win command-window)
|
||||
command-buffer)
|
||||
;;(debug-message "loop after print-command-buffer " command-buffer)
|
||||
(move-cursor command-buffer)
|
||||
(refresh-command-window)
|
||||
(loop (wait-for-input) c-x-pressed?)))))
|
||||
|
||||
(define (window-init-curses-win! window)
|
||||
(set-app-window-curses-win!
|
||||
|
|
@ -454,30 +452,31 @@
|
|||
(make-app-window 1 1
|
||||
(- (COLS) 2) 2
|
||||
#f))
|
||||
(set! bar-2
|
||||
(set! active-command-window
|
||||
(make-app-window 1 (+ (round (/ (LINES) 3)) 2)
|
||||
(- (COLS) 2) 3
|
||||
#f))
|
||||
(set! command-frame-window
|
||||
(make-app-window 1 2
|
||||
(- (COLS) 2) (- (app-window-y bar-2) 2)
|
||||
(- (COLS) 2) (- (app-window-y active-command-window) 2)
|
||||
#f))
|
||||
(set! command-window
|
||||
(make-inlying-app-window command-frame-window))
|
||||
(set! result-frame-window
|
||||
(make-app-window 1 (+ (app-window-y bar-2) 3)
|
||||
(make-app-window 1 (+ (app-window-y active-command-window) 3)
|
||||
(- (COLS) 2)
|
||||
(- (- (LINES) 6) (app-window-height command-frame-window))
|
||||
#f))
|
||||
(set! result-window
|
||||
(make-inlying-app-window result-frame-window))
|
||||
|
||||
(let ((all-windows (list bar-1 bar-2
|
||||
(let ((all-windows (list bar-1 active-command-window
|
||||
command-frame-window command-window
|
||||
result-frame-window result-window)))
|
||||
(for-each window-init-curses-win! all-windows)
|
||||
|
||||
(debug-message "init-windows!: bar-1 " bar-1 " bar-2 " bar-2
|
||||
(debug-message "init-windows!: bar-1 " bar-1
|
||||
" active-command-window " active-command-window
|
||||
" command-frame-window " command-frame-window
|
||||
" command-window " command-window
|
||||
" result-frame-window " result-frame-window
|
||||
|
|
@ -490,11 +489,6 @@
|
|||
(mvwaddstr (app-window-curses-win bar-1) 0 1 "SCSH-NUIT")
|
||||
(wrefresh (app-window-curses-win bar-1)))
|
||||
|
||||
(define (paint-bar-2)
|
||||
(box (app-window-curses-win bar-2) (ascii->char 0) (ascii->char 0))
|
||||
(print-active-command-win (app-window-curses-win bar-2)
|
||||
(app-window-width bar-2)))
|
||||
|
||||
(define (paint-command-frame-window)
|
||||
(box (app-window-curses-win command-frame-window)
|
||||
(ascii->char 0) (ascii->char 0))
|
||||
|
|
@ -521,9 +515,15 @@
|
|||
(set! result-cols (- (app-window-width result-window) 3))
|
||||
(wrefresh win)))
|
||||
|
||||
(define (paint-result-window)
|
||||
(define (paint-result-window entry)
|
||||
(wclear (app-window-curses-win result-window))
|
||||
(print-result-buffer))
|
||||
(paint-result-buffer
|
||||
(post-message
|
||||
(or (history-entry-receiver entry)
|
||||
(determine-receiver-by-command (history-entry-command entry)))
|
||||
(make-print-message (history-entry-command entry)
|
||||
(history-entry-result entry)
|
||||
(buffer-num-cols command-buffer)))))
|
||||
|
||||
(define (refresh-result-window)
|
||||
(wrefresh (app-window-curses-win result-window)))
|
||||
|
|
@ -531,11 +531,11 @@
|
|||
(define (paint)
|
||||
(debug-message "paint")
|
||||
(paint-bar-1)
|
||||
(paint-bar-2)
|
||||
(paint-command-frame-window)
|
||||
(paint-command-window-contents)
|
||||
(paint-active-command-window)
|
||||
(paint-result-frame-window)
|
||||
(paint-result-window)
|
||||
;(paint-result-window)
|
||||
(move-cursor command-buffer)
|
||||
(refresh-command-window)
|
||||
(refresh-result-window))
|
||||
|
|
@ -548,9 +548,20 @@
|
|||
(echo)
|
||||
ch))
|
||||
|
||||
;;If the user presses enter the last line is interpreted as a command
|
||||
;;which has to be executed.
|
||||
(define (execute-command)
|
||||
(define (execute-command command)
|
||||
(let ((result (evaluate command)))
|
||||
(cond
|
||||
((determine-receiver-by-type result)
|
||||
=> (lambda (receiver)
|
||||
(values result receiver)))
|
||||
(else
|
||||
(values
|
||||
(post-message standard-receiver
|
||||
(make-next-command-message
|
||||
command '() (buffer-num-cols command-buffer)))
|
||||
standard-receiver)))))
|
||||
|
||||
'(define (execute-command)
|
||||
(let* ((com (list-ref (buffer-text command-buffer)
|
||||
(- (length (buffer-text command-buffer)) 1)))
|
||||
(com-par (extract-com-and-par com))
|
||||
|
|
@ -559,14 +570,25 @@
|
|||
;;todo: parameters
|
||||
(message (make-next-command-message
|
||||
command parameters result-cols))
|
||||
(model (switch message)))
|
||||
(model (post-message
|
||||
(determine-receiver-by-command command)
|
||||
message)))
|
||||
(debug-message 'execute-command
|
||||
com " " com-par )
|
||||
(if (not (= history-pos 0))
|
||||
(let ((hist-entry (make-history-entry active-command
|
||||
active-parameters
|
||||
current-result-object))
|
||||
(let ((hist-entry (make-history-entry (active-command)
|
||||
(active-command-arguments)
|
||||
(current-result)))
|
||||
;; hack of year
|
||||
(active (make-history-entry command
|
||||
(get-param-as-str parameters)
|
||||
model)))
|
||||
(if (standard-result-obj? model)
|
||||
(standard-result-obj-result model)
|
||||
model)
|
||||
(and (standard-result-obj? model)
|
||||
(determine-receiver-by-type
|
||||
(standard-result-obj-result model))))))
|
||||
|
||||
(if (< history-pos (length history))
|
||||
(set! history (append history (list hist-entry)))
|
||||
(set! history (append
|
||||
|
|
@ -585,7 +607,7 @@
|
|||
(list "")))
|
||||
(set! active-command command)
|
||||
(set! active-parameters (get-param-as-str parameters))
|
||||
(set! current-result-object model)
|
||||
(set! (current-result) model)
|
||||
(scroll-command-buffer)))
|
||||
|
||||
;;Extracts the name of the function and its parameters
|
||||
|
|
@ -651,34 +673,37 @@
|
|||
(+ (buffer-pos-line command-buffer) 1))
|
||||
(set-buffer-pos-col! command-buffer 2))
|
||||
|
||||
;;evaluate an expression given as a string
|
||||
(define (evaluate exp)
|
||||
(let* ((command-port (open-input-string exp))
|
||||
(handler (lambda (condition more)
|
||||
(cons 'Error: condition)))
|
||||
(structure (reify-structure 'scheme-with-scsh))
|
||||
(s (load-structure structure))
|
||||
(env (rt-structure->environment structure))
|
||||
(result (with-fatal-error-handler
|
||||
handler
|
||||
(eval (read command-port) env))))
|
||||
result))
|
||||
(define (init-evaluation-environment package)
|
||||
(let ((structure (reify-structure package)))
|
||||
(load-structure structure)
|
||||
(rt-structure->environment structure)))
|
||||
|
||||
;;Message-Passing
|
||||
;;switch manages that the messages are delivered in the correct way
|
||||
(define (switch message)
|
||||
(cond
|
||||
((get-receiver (message-command-string message))
|
||||
=> (lambda (receiver)
|
||||
((receiver-rec receiver) message)))
|
||||
(else
|
||||
(standard-receiver message))))
|
||||
(define (read-sexp-from-string string)
|
||||
(let ((string-port (open-input-string string)))
|
||||
(read string-port)))
|
||||
|
||||
(define (get-receiver command)
|
||||
(define evaluate
|
||||
(let ((env (init-evaluation-environment 'nuit-eval-structure)))
|
||||
(lambda (exp)
|
||||
(with-fatal-error-handler
|
||||
(lambda (condition more)
|
||||
(cons 'error condition))
|
||||
(eval (read-sexp-from-string exp) env)))))
|
||||
|
||||
(define (post-message receiver message)
|
||||
((receiver-rec receiver) message))
|
||||
|
||||
(define (determine-receiver-by-command command)
|
||||
(or (find (lambda (r)
|
||||
(string=? (receiver-command r) command))
|
||||
receivers)
|
||||
standard-receiver))
|
||||
|
||||
(define (determine-receiver-by-type result)
|
||||
(find (lambda (r)
|
||||
(string=? (receiver-command r) command))
|
||||
((receiver-type-predicate r) result))
|
||||
receivers))
|
||||
|
||||
|
||||
;;Management of the upper buffer
|
||||
;;add a char to the buffer
|
||||
(define (add-to-command-buffer ch)
|
||||
|
|
@ -707,7 +732,6 @@
|
|||
(let ((first-ch (string-ref str 0)))
|
||||
(add-to-command-buffer (char->ascii first-ch))
|
||||
(loop (substring str 1 (string-length str)))))))
|
||||
|
||||
|
||||
;;selection of the visible area of the buffer
|
||||
(define (prepare-lines l height pos)
|
||||
|
|
@ -720,38 +744,40 @@
|
|||
(sublist l 0 height)
|
||||
(sublist l (- pos height) height))))
|
||||
|
||||
;;print the active-command window:
|
||||
(define (print-active-command-win win width)
|
||||
(if (<= width 25)
|
||||
(values)
|
||||
(let ((active-command (string-append active-command
|
||||
active-parameters)))
|
||||
(if (> (string-length active-command) (- width 25))
|
||||
(let* ((com-txt (substring active-command
|
||||
0
|
||||
(- width 25)))
|
||||
(whole-text (string-append "Active Command: "
|
||||
com-txt
|
||||
"...")))
|
||||
(mvwaddstr win 1 2 whole-text)
|
||||
(wrefresh win))
|
||||
(begin
|
||||
(mvwaddstr win 1 2 (string-append "Active Command: "
|
||||
active-command))
|
||||
(wrefresh win))))))
|
||||
;;; FIXME: I guess s48 knows a better way to do this (see ,inspect)
|
||||
(define (maybe-shorten-string string width)
|
||||
(if (> (string-length string) width)
|
||||
(string-append (substring string 0 (- width 3))
|
||||
"...")
|
||||
string))
|
||||
|
||||
;;print the lower window
|
||||
(define (print-result-buffer)
|
||||
(define (paint-active-command-window)
|
||||
(let ((win (app-window-curses-win active-command-window))
|
||||
(width (app-window-width active-command-window)))
|
||||
(wclear win)
|
||||
(box win (ascii->char 0) (ascii->char 0))
|
||||
(cond
|
||||
((current-history-item)
|
||||
=> (lambda (entry)
|
||||
(mvwaddstr win 1 2
|
||||
(maybe-shorten-string
|
||||
(history-entry-command (entry-data entry)) width)))))
|
||||
(wrefresh win)))
|
||||
|
||||
(define (post-print-message command result-object)
|
||||
(post-message
|
||||
(determine-receiver-by-command command)
|
||||
(make-print-message command result-object
|
||||
(buffer-num-cols command-buffer))))
|
||||
|
||||
(define (paint-result-buffer print-object)
|
||||
(debug-message "paint-result-buffer ")
|
||||
(let* ((window (app-window-curses-win result-window))
|
||||
(print-message (make-print-message active-command
|
||||
current-result-object
|
||||
(buffer-num-cols command-buffer)))
|
||||
(model (switch print-message))
|
||||
(text (print-object-text model))
|
||||
(pos-y (print-object-pos-y model))
|
||||
(pos-x (print-object-pos-x model))
|
||||
(highlighted-lns (print-object-highlighted-lines model))
|
||||
(marked-lns (print-object-marked-lines model)))
|
||||
(text (print-object-text print-object))
|
||||
(pos-y (print-object-pos-y print-object))
|
||||
(pos-x (print-object-pos-x print-object))
|
||||
(highlighted-lns (print-object-highlighted-lines print-object))
|
||||
(marked-lns (print-object-marked-lines print-object)))
|
||||
(set! text-result text)
|
||||
(set! pos-result pos-y)
|
||||
(set! pos-result-col pos-x)
|
||||
|
|
@ -765,7 +791,7 @@
|
|||
(values)
|
||||
(let ((line (list-ref lines (- pos 1))))
|
||||
(begin
|
||||
(if (not (standard-result-obj? current-result-object))
|
||||
(if (not (standard-result-obj? (current-result)))
|
||||
(set! line
|
||||
(if (> (string-length line) result-cols)
|
||||
(let ((start-line
|
||||
|
|
@ -901,36 +927,7 @@
|
|||
; (last-string (make-string num-blanks #\space)))
|
||||
; (mvwaddstr bar3 2 (+ used-width 1) last-string))
|
||||
; (wrefresh bar3)))))))))
|
||||
|
||||
|
||||
|
||||
;; one step back in the history
|
||||
(define (history-back)
|
||||
(if (<= history-pos 0)
|
||||
(values)
|
||||
(let* ((hist-entry (list-ref history (- history-pos 1)))
|
||||
(entry-com (history-entry-command hist-entry))
|
||||
(entry-par (history-entry-parameters hist-entry))
|
||||
(entry-res-obj (history-entry-result-object hist-entry)))
|
||||
(set! active-command entry-com)
|
||||
(set! active-parameters entry-par)
|
||||
(set! current-result-object entry-res-obj)
|
||||
(if (> history-pos 1)
|
||||
(set! history-pos (- history-pos 1))))))
|
||||
|
||||
;;one step forward
|
||||
(define (history-forward)
|
||||
(if (> history-pos (- (length history) 1))
|
||||
(values)
|
||||
(let* ((hist-entry (list-ref history history-pos))
|
||||
(entry-com (history-entry-command hist-entry))
|
||||
(entry-par (history-entry-parameters hist-entry))
|
||||
(entry-res-obj (history-entry-result-object hist-entry)))
|
||||
(set! active-command entry-com)
|
||||
(set! active-parameters entry-par)
|
||||
(set! current-result-object entry-res-obj)
|
||||
(set! history-pos (+ history-pos 1)))))
|
||||
|
||||
(define (sublist l pos k)
|
||||
(let ((tmp (list-tail l pos)))
|
||||
(reverse (list-tail (reverse tmp)
|
||||
|
|
@ -950,9 +947,6 @@
|
|||
(set! marked-lines '())
|
||||
(set! history '())
|
||||
(set! history-pos 0)
|
||||
(set! active-command "")
|
||||
(set! active-parameters "")
|
||||
(set! current-result-object init-std-res)
|
||||
(set! active-keyboard-interrupt #f))
|
||||
|
||||
;;Shortcuts-receiver:
|
||||
|
|
@ -1001,22 +995,16 @@
|
|||
(define init-std-res (make-standard-result-obj 1 1 text-result
|
||||
(car text-result)))
|
||||
|
||||
(set! current-result-object init-std-res)
|
||||
|
||||
|
||||
;;Standard-Receiver:
|
||||
(define (standard-receiver message)
|
||||
(define (standard-receiver-rec message)
|
||||
(cond
|
||||
((next-command-message? message)
|
||||
(let* ((command (next-command-string message))
|
||||
(result (evaluate command))
|
||||
(let* ((result (evaluate (message-command-string message)))
|
||||
(result-string (exp->string result))
|
||||
(width (next-command-message-width message)))
|
||||
(let* ((text
|
||||
(layout-result-standard result-string result width))
|
||||
(std-obj
|
||||
(make-standard-result-obj 1 1 text result)))
|
||||
std-obj)))
|
||||
(width (next-command-message-width message))
|
||||
(text (layout-result-standard result-string result 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))
|
||||
|
|
@ -1033,6 +1021,9 @@
|
|||
((selection-message? message)
|
||||
"")))
|
||||
|
||||
(define standard-receiver
|
||||
(make-receiver #f standard-receiver-rec))
|
||||
|
||||
;;the result is the "answer" of scsh
|
||||
(define (layout-result-standard result-str result width)
|
||||
(reverse (seperate-line result-str width)))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,33 @@
|
|||
;;; history data structure
|
||||
|
||||
(define-interface history-interface
|
||||
(export make-empty-history
|
||||
history?
|
||||
entry?
|
||||
entry-data
|
||||
append-history-item!
|
||||
insert-history-item!
|
||||
history-next-entry
|
||||
history-prev-entry
|
||||
history-first-entry
|
||||
history-last-entry))
|
||||
|
||||
(define-structure history history-interface
|
||||
(open scheme
|
||||
define-record-types)
|
||||
(files history))
|
||||
|
||||
;;; nuit evaluates the expressions entered into command buffer in this
|
||||
;;; package
|
||||
|
||||
(define-structure nuit-eval-structure (export)
|
||||
(open scheme-with-scsh
|
||||
srfi-1
|
||||
pps)
|
||||
(begin))
|
||||
|
||||
;;; nuit
|
||||
|
||||
(define-interface nuit-interface
|
||||
(export nuit))
|
||||
|
||||
|
|
@ -16,7 +46,8 @@
|
|||
inspect-exception
|
||||
rt-modules
|
||||
tty-debug
|
||||
pps)
|
||||
pps
|
||||
history)
|
||||
(files nuit-engine
|
||||
handle-fatal-error
|
||||
directory-files
|
||||
|
|
@ -26,3 +57,6 @@
|
|||
browse-list
|
||||
process))
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,7 @@
|
|||
(define (list-of-processes? thing)
|
||||
(and (proper-list? thing)
|
||||
(every process-info? thing)))
|
||||
|
||||
(define (print-processes processes)
|
||||
(map (lambda (pi)
|
||||
(apply format
|
||||
|
|
@ -14,6 +18,7 @@
|
|||
processes))
|
||||
|
||||
(define (pps-receiver message)
|
||||
(debug-message "pps-receiver " message)
|
||||
(cond
|
||||
((next-command-message? message)
|
||||
(pps))
|
||||
|
|
@ -28,9 +33,7 @@
|
|||
((selection-message? message)
|
||||
"'()")))
|
||||
|
||||
(set! receivers (cons (make-receiver "ps" pps-receiver)
|
||||
(set! receivers (cons (make-receiver "ps" pps-receiver
|
||||
list-of-processes?)
|
||||
receivers))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue