888 lines
25 KiB
Scheme
888 lines
25 KiB
Scheme
;; ,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).
|
|
;;In the upper buffer simply the functionalities of scsh-ncurses:
|
|
;;input-buffer are used.
|
|
;;The lower window is meant to be used more flexible. Depending on
|
|
;;the active command the key-inputs are routed to the correct receiver,
|
|
;;where one can specify how to react.
|
|
|
|
;;*************************************************************************
|
|
;;State
|
|
|
|
(define-record-type app-window :app-window
|
|
(make-app-window x y width height curses-win)
|
|
app-window?
|
|
(x app-window-x)
|
|
(y app-window-y)
|
|
(width app-window-width)
|
|
(height app-window-height)
|
|
(curses-win app-window-curses-win set-app-window-curses-win!))
|
|
|
|
(define-record-discloser :app-window
|
|
(lambda (rec)
|
|
`(app-window
|
|
(x ,(app-window-x rec)) (y ,(app-window-y rec))
|
|
(w ,(app-window-width rec)) (h ,(app-window-height rec)))))
|
|
|
|
(define bar-1 #f)
|
|
(define active-command-window #f)
|
|
|
|
(define command-frame-window #f)
|
|
(define command-window #f)
|
|
|
|
(define result-window #f)
|
|
(define result-frame-window #f)
|
|
|
|
(define key-control-x 24)
|
|
(define key-o 111)
|
|
(define key-tab 9)
|
|
|
|
;;state of the upper window (Command-Window)
|
|
(define command-buffer
|
|
(make-buffer '("Welcome to the scsh-ncurses-ui!" "")
|
|
2 2 2 1 1
|
|
0 0
|
|
#t 1))
|
|
|
|
;;state of the lower window (Result-Window)
|
|
;;----------------------------
|
|
;;Text
|
|
(define text-result (list "Type 'shortcuts' for help"))
|
|
|
|
;;line of the result-window
|
|
(define pos-result 0)
|
|
|
|
;;column
|
|
(define pos-result-col 0)
|
|
|
|
;;y-coordinate of the cursor in the result-buffer
|
|
(define result-buffer-pos-y 0)
|
|
|
|
;;x-coordinate of the cursor in the result-buffer
|
|
(define result-buffer-pos-x 0)
|
|
|
|
;;lines of the lower window
|
|
(define result-lines 0)
|
|
|
|
;;columns in the lower window
|
|
(define result-cols 0)
|
|
|
|
;;lines to be highlighted
|
|
(define highlighted-lines '())
|
|
|
|
;;lines to be marked
|
|
(define marked-lines '())
|
|
|
|
;;miscelaneous state
|
|
;;-------------------
|
|
|
|
(define *focus-buffer* 'command-buffer)
|
|
|
|
(define (focus-on-command-buffer?)
|
|
(eq? *focus-buffer* 'command-buffer))
|
|
|
|
(define (focus-command-buffer!)
|
|
(set! *focus-buffer* 'command-buffer))
|
|
|
|
(define (focus-on-result-buffer?)
|
|
(eq? *focus-buffer* 'result-buffer))
|
|
|
|
(define (focus-result-buffer!)
|
|
(set! *focus-buffer* 'result-buffer))
|
|
|
|
;; mode of the command buffer
|
|
(define *command-buffer-mode* 'scheme)
|
|
|
|
(define (command-buffer-in-scheme-mode?)
|
|
(eq? *command-buffer-mode* 'scheme))
|
|
|
|
(define (command-buffer-in-command-mode?)
|
|
(eq? *command-buffer-mode* 'command))
|
|
|
|
(define (enter-scheme-mode!)
|
|
(set! *command-buffer-mode* 'scheme))
|
|
|
|
(define (enter-command-mode!)
|
|
(set! *command-buffer-mode* 'command))
|
|
|
|
;; History
|
|
|
|
(define history-pos 0)
|
|
(define the-history (make-empty-history))
|
|
|
|
(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 plugin)
|
|
history-entry?
|
|
(command history-entry-command)
|
|
(args history-entry-args)
|
|
(result history-entry-result set-history-entry-result!)
|
|
(plugin history-entry-plugin))
|
|
|
|
(define (current-history-entry-selector-maker selector)
|
|
(lambda ()
|
|
(cond
|
|
((current-history-item)
|
|
=> (lambda (entry)
|
|
(selector (entry-data entry))))
|
|
(else #f))))
|
|
|
|
(define active-command
|
|
(current-history-entry-selector-maker history-entry-command))
|
|
|
|
(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 entry) 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.
|
|
;;If a keyboard-interrupt occurs this can be checked by looking-up this box
|
|
(define active-keyboard-interrupt #f)
|
|
|
|
|
|
;;The "user" (who extends the functionality of NUIT) has to inform NUIT
|
|
;;about which function is meant to be the receiver, when a certain
|
|
;;command is active
|
|
|
|
;;*************************************************************************
|
|
;;Actions
|
|
|
|
;;start the whole thing
|
|
(define (nuit)
|
|
(let ((tty-name (init-tty-debug-output!)))
|
|
(display "Debug messages will be on ")
|
|
(display tty-name)
|
|
(newline))
|
|
(with-inspecting-handler
|
|
8888
|
|
(lambda (condition)
|
|
(with-current-output-port*
|
|
(error-output-port)
|
|
(lambda ()
|
|
(display "starting remote handler for condition")
|
|
(display condition)
|
|
(newline)
|
|
(display "Please connect to port 8888")
|
|
(newline)
|
|
#t)))
|
|
run))
|
|
|
|
(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))))
|
|
|
|
(define (toggle-command/scheme-mode)
|
|
(cond
|
|
((command-buffer-in-command-mode?)
|
|
(enter-scheme-mode!))
|
|
((command-buffer-in-scheme-mode?)
|
|
(enter-command-mode!)))
|
|
(paint-command-frame-window)
|
|
(paint-command-window-contents)
|
|
(move-cursor command-buffer)
|
|
(refresh-command-window))
|
|
|
|
(define (handle-return-key)
|
|
(let ((command-line (last (buffer-text command-buffer))))
|
|
(cond
|
|
((string=? command-line "")
|
|
(values))
|
|
((command-buffer-in-scheme-mode?)
|
|
(eval-command-in-scheme-mode command-line))
|
|
((command-buffer-in-command-mode?)
|
|
(eval-command-in-command-mode command-line)))))
|
|
|
|
(define (find-command-plugin command)
|
|
(or (find (lambda (p)
|
|
(string=? (command-plugin-command p) command))
|
|
(command-plugin-list))
|
|
standard-command-plugin))
|
|
|
|
(define (eval-command-in-command-mode command-line)
|
|
(let* ((tokens (split-command-line command-line))
|
|
(command (car tokens))
|
|
(args (cdr tokens))
|
|
(command-plugin (find-command-plugin command)))
|
|
(call-with-values
|
|
(lambda ()
|
|
(find/init-plugin-for-result
|
|
((command-plugin-evaluater command-plugin) command args)))
|
|
(lambda (result plugin)
|
|
(let ((new-entry
|
|
(make-history-entry command args
|
|
result plugin)))
|
|
;; FIXME, use insert here
|
|
(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)
|
|
(call-with-values
|
|
(lambda ()
|
|
(find/init-plugin-for-result
|
|
(eval-expression command-line)))
|
|
(lambda (result plugin)
|
|
(let* ((tokens (split-command-line command-line))
|
|
(command (car tokens))
|
|
(args (cdr tokens))
|
|
(new-entry
|
|
(make-history-entry command args
|
|
result plugin)))
|
|
;; FIXME, use insert here
|
|
(append-to-history! new-entry)
|
|
(buffer-text-append-new-line! command-buffer)
|
|
(paint-result/command-buffer new-entry)))))
|
|
|
|
(define split-command-line string-tokenize)
|
|
|
|
;; handle input
|
|
(define (run)
|
|
|
|
(init-windows!)
|
|
'(set-interrupt-handler interrupt/keyboard
|
|
(lambda a
|
|
(set! active-keyboard-interrupt a)))
|
|
|
|
;;Loop
|
|
(paint)
|
|
(let loop ((ch (wait-for-input)) (c-x-pressed? #f))
|
|
(cond
|
|
|
|
;; Ctrl-x -> wait for next input
|
|
((= ch key-control-x)
|
|
(loop (wait-for-input) #t))
|
|
|
|
((= ch key-tab)
|
|
(debug-message "Should do completion now")
|
|
(loop (wait-for-input) #f))
|
|
|
|
;; F7 toggle scheme-mode / command-mode (FIXME: find a better key)
|
|
((= ch key-f7)
|
|
(toggle-command/scheme-mode)
|
|
(loop (wait-for-input) #f))
|
|
|
|
;; 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-plugin (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)
|
|
(endwin))
|
|
|
|
((= ch key-f2)
|
|
(paint)
|
|
(loop (wait-for-input) c-x-pressed?))
|
|
|
|
;; forward in result history
|
|
((= ch key-npage)
|
|
(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) c-x-pressed?))
|
|
|
|
;; back in result history
|
|
((= ch key-ppage)
|
|
(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) c-x-pressed?))
|
|
|
|
((= ch 10)
|
|
(handle-return-key)
|
|
(loop (wait-for-input) c-x-pressed?))
|
|
|
|
(else
|
|
(cond
|
|
((focus-on-result-buffer?)
|
|
(when (current-history-item)
|
|
(update-current-result!
|
|
(post-message
|
|
(history-entry-plugin (entry-data (current-history-item)))
|
|
(make-key-pressed-message
|
|
(active-command) (current-result)
|
|
ch c-x-pressed?)))
|
|
(paint-result-window (entry-data (current-history-item)))
|
|
(refresh-result-window))
|
|
(loop (wait-for-input) #f))
|
|
(else
|
|
(input command-buffer ch)
|
|
(werase (app-window-curses-win command-window))
|
|
(print-command-buffer (app-window-curses-win command-window)
|
|
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!
|
|
window
|
|
(newwin (app-window-height window) (app-window-width window)
|
|
(app-window-y window) (app-window-x window))))
|
|
|
|
(define (make-inlying-app-window outer-window)
|
|
(make-app-window (+ (app-window-x outer-window) 1)
|
|
(+ (app-window-y outer-window) 1)
|
|
(- (app-window-width outer-window) 2)
|
|
(- (app-window-height outer-window) 2)
|
|
#f))
|
|
|
|
(define (init-windows!)
|
|
(init-screen)
|
|
(set! bar-1
|
|
(make-app-window 1 1
|
|
(- (COLS) 2) 2
|
|
#f))
|
|
(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 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 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 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
|
|
" active-command-window " active-command-window
|
|
" command-frame-window " command-frame-window
|
|
" command-window " command-window
|
|
" result-frame-window " result-frame-window
|
|
" result-window " result-window)
|
|
(for-each wclear
|
|
(map app-window-curses-win all-windows))
|
|
(clear)))
|
|
|
|
(define (paint-bar-1)
|
|
(mvwaddstr (app-window-curses-win bar-1) 0 1 "SCSH-NUIT")
|
|
(wrefresh (app-window-curses-win bar-1)))
|
|
|
|
(define (paint-command-buffer-mode-indicator)
|
|
(let ((mode-string
|
|
(string-append
|
|
"[ "
|
|
(if (command-buffer-in-command-mode?)
|
|
"Command"
|
|
"Scheme")
|
|
" ]")))
|
|
(mvwaddstr
|
|
(app-window-curses-win command-frame-window)
|
|
0
|
|
(- (- (app-window-width command-frame-window)
|
|
(string-length mode-string))
|
|
2)
|
|
mode-string)))
|
|
|
|
(define (paint-command-frame-window)
|
|
(box (app-window-curses-win command-frame-window)
|
|
(ascii->char 0) (ascii->char 0))
|
|
(paint-command-buffer-mode-indicator)
|
|
(wrefresh (app-window-curses-win command-frame-window)))
|
|
|
|
(define (paint-command-window-contents)
|
|
(set-buffer-num-lines! command-buffer
|
|
(- (app-window-height command-window) 2))
|
|
(set-buffer-num-cols! command-buffer
|
|
(- (app-window-width command-window) 3))
|
|
(werase (app-window-curses-win command-window))
|
|
(print-command-buffer (app-window-curses-win command-window)
|
|
command-buffer))
|
|
|
|
(define (refresh-command-window)
|
|
(wrefresh (app-window-curses-win command-window)))
|
|
|
|
(define (paint-result-frame-window)
|
|
(let ((win (app-window-curses-win result-frame-window)))
|
|
(wclear win)
|
|
(box win (ascii->char 0) (ascii->char 0))
|
|
;;; EK: wtf is going on here?
|
|
(set! result-lines (- (app-window-height result-window) 2))
|
|
(set! result-cols (- (app-window-width result-window) 3))
|
|
(wrefresh win)))
|
|
|
|
(define (paint-result-window entry)
|
|
(wclear (app-window-curses-win result-window))
|
|
(paint-result-buffer
|
|
(post-message
|
|
(history-entry-plugin 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)))
|
|
|
|
(define (paint-result/command-buffer history-entry)
|
|
(paint-result-window history-entry)
|
|
(paint-active-command-window)
|
|
(scroll-command-buffer)
|
|
(paint-command-window-contents)
|
|
(move-cursor command-buffer)
|
|
(refresh-result-window)
|
|
(refresh-command-window))
|
|
|
|
(define (paint)
|
|
(debug-message "paint")
|
|
(paint-bar-1)
|
|
(paint-command-frame-window)
|
|
(paint-command-window-contents)
|
|
(paint-active-command-window)
|
|
(paint-result-frame-window)
|
|
;(paint-result-window)
|
|
(move-cursor command-buffer)
|
|
(refresh-command-window)
|
|
(refresh-result-window))
|
|
|
|
(define (wait-for-input)
|
|
(noecho)
|
|
(keypad (app-window-curses-win bar-1) #t)
|
|
(set! active-keyboard-interrupt #f)
|
|
(let ((ch (wgetch (app-window-curses-win bar-1))))
|
|
(echo)
|
|
ch))
|
|
|
|
(define (find/init-plugin-for-result result)
|
|
(cond
|
|
((determine-plugin-by-type result)
|
|
=> (lambda (plugin)
|
|
(values
|
|
(post-message plugin
|
|
(make-init-with-result-message
|
|
result (buffer-num-cols command-buffer)))
|
|
plugin)))
|
|
(else
|
|
(values
|
|
(post-message standard-view-plugin
|
|
(make-init-with-result-message
|
|
result (buffer-num-cols command-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
|
|
(define (scroll-command-buffer)
|
|
(set-buffer-pos-line! command-buffer
|
|
(+ (buffer-pos-line command-buffer) 1))
|
|
(set-buffer-pos-col! command-buffer 2))
|
|
|
|
(define (init-evaluation-environment package)
|
|
(let ((structure (reify-structure package)))
|
|
(load-structure structure)
|
|
(rt-structure->environment structure)))
|
|
|
|
(define (read-sexp-from-string string)
|
|
(let ((string-port (open-input-string string)))
|
|
(read string-port)))
|
|
|
|
(define eval-expression
|
|
(let ((env (init-evaluation-environment 'nuit-eval)))
|
|
(lambda (exp)
|
|
(with-fatal-and-capturing-error-handler
|
|
(lambda (condition continuation decline)
|
|
continuation)
|
|
(lambda ()
|
|
(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)
|
|
(find (lambda (r)
|
|
((view-plugin-type-predicate r) result))
|
|
(view-plugin-list)))
|
|
|
|
;;Management of the upper buffer
|
|
;;add a char to the buffer
|
|
(define (add-to-command-buffer ch)
|
|
(let* ((text (buffer-text command-buffer))
|
|
(last-pos (- (length text) 1))
|
|
(old-last-el (list-ref text last-pos))
|
|
(old-rest (sublist text 0 last-pos))
|
|
(before-ch (substring old-last-el 0
|
|
(max 0 (- (buffer-pos-col command-buffer) 2))))
|
|
(after-ch (substring old-last-el
|
|
(max 0 (- (buffer-pos-col command-buffer) 2))
|
|
(string-length old-last-el)))
|
|
(new-last-el (string-append before-ch
|
|
(string (ascii->char ch))
|
|
after-ch)))
|
|
(set-buffer-text! command-buffer
|
|
(append old-rest (list new-last-el)))
|
|
(set-buffer-pos-col! command-buffer
|
|
(+ (buffer-pos-col command-buffer) 1))))
|
|
|
|
;;add a string to the buffer
|
|
(define (add-string-to-command-buffer string)
|
|
(let loop ((str string))
|
|
(if (string=? str "")
|
|
(values)
|
|
(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)
|
|
(if (< (length l) height)
|
|
(let loop ((tmp-list l))
|
|
(if (= height (length tmp-list))
|
|
tmp-list
|
|
(loop (append tmp-list (list "")))))
|
|
(if (< pos height)
|
|
(sublist l 0 height)
|
|
(sublist l (- pos height) height))))
|
|
|
|
;;; 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))
|
|
|
|
(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 (paint-result-buffer print-object)
|
|
(let* ((window (app-window-curses-win result-window))
|
|
(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)
|
|
(set! highlighted-lines highlighted-lns)
|
|
(set! marked-lines marked-lns)
|
|
(right-highlighted-lines)
|
|
(right-marked-lines)
|
|
(let ((lines (get-right-result-lines)))
|
|
(let loop ((pos 1))
|
|
(if (> pos result-lines)
|
|
(values)
|
|
(let ((line (list-ref lines (- pos 1))))
|
|
(begin
|
|
(if (not (standard-result-obj? (current-result)))
|
|
(set! line
|
|
(if (> (string-length line) result-cols)
|
|
(let ((start-line
|
|
(substring line 0
|
|
(- (ceiling (/ result-cols 2))
|
|
3)))
|
|
(end-line
|
|
(substring line
|
|
(- (string-length line)
|
|
(ceiling
|
|
(/ result-cols 2)))
|
|
(string-length line))))
|
|
(string-append start-line "..." end-line))
|
|
line)))
|
|
(if (and (member pos highlighted-lines)
|
|
(focus-on-result-buffer?))
|
|
(begin
|
|
(wattron window (A-REVERSE))
|
|
(mvwaddstr window pos 1 line)
|
|
(wattrset window (A-NORMAL))
|
|
;(wrefresh window)
|
|
(loop (+ pos 1)))
|
|
(if (member pos marked-lines)
|
|
(begin
|
|
(wattron window (A-BOLD))
|
|
(mvwaddstr window pos 1 line)
|
|
(wattrset window (A-NORMAL))
|
|
;(wrefresh window)
|
|
(loop (+ pos 1)))
|
|
(begin
|
|
(mvwaddstr window pos 1 line)
|
|
;(wrefresh window)
|
|
(loop (+ pos 1))))))))))))
|
|
|
|
;;visible lines
|
|
(define (get-right-result-lines)
|
|
(prepare-lines text-result result-lines pos-result))
|
|
|
|
;;marked and highlighted lines
|
|
(define (right-highlighted-lines)
|
|
(let loop ((old highlighted-lines)
|
|
(new '()))
|
|
(if (null? old)
|
|
(set! highlighted-lines new)
|
|
(let ((el (car old)))
|
|
(if (<= pos-result result-lines)
|
|
;;auf der ersten Seite
|
|
(loop (cdr old)
|
|
(append new (list el)))
|
|
(let* ((offset (- pos-result result-lines))
|
|
(new-el (- el offset )))
|
|
(loop (cdr old)
|
|
(append new (list new-el)))))))))
|
|
|
|
(define (right-marked-lines)
|
|
(let loop ((old marked-lines)
|
|
(new '()))
|
|
(if (null? old)
|
|
(set! marked-lines new)
|
|
(let ((el (car old)))
|
|
(if (<= pos-result result-lines)
|
|
;;auf der ersten Seite
|
|
(loop (cdr old)
|
|
(append new (list el)))
|
|
(let* ((offset (- pos-result result-lines))
|
|
(new-el (- el offset )))
|
|
(loop (cdr old)
|
|
(append new (list new-el)))))))))
|
|
|
|
;;Cursor
|
|
;;move cursor to the corrct position
|
|
(define (move-cursor buffer)
|
|
(if (focus-on-command-buffer?)
|
|
(cursor-right-pos (app-window-curses-win command-window)
|
|
buffer)
|
|
(begin
|
|
(compute-y-x)
|
|
(wmove (app-window-curses-win result-window)
|
|
result-buffer-pos-y result-buffer-pos-x)
|
|
(wrefresh (app-window-curses-win result-window))
|
|
buffer)))
|
|
|
|
;;compue pos-x and pos-y
|
|
(define (compute-y-x)
|
|
(if (>= pos-result result-lines)
|
|
(set! result-buffer-pos-y result-lines)
|
|
(set! result-buffer-pos-y pos-result))
|
|
(set! result-buffer-pos-x pos-result-col))
|
|
|
|
(define (sublist l pos k)
|
|
(let ((tmp (list-tail l pos)))
|
|
(reverse (list-tail (reverse tmp)
|
|
(- (length tmp) k)))))
|
|
|
|
;;When NUIT is closed the state has to be restored, in order to let the
|
|
;;user start again from scratch
|
|
(define (restore-state)
|
|
(set! text-result (list "Start entering commands."))
|
|
(set! pos-result 0)
|
|
(set! pos-result-col 0)
|
|
(set! result-buffer-pos-y 0)
|
|
(set! result-buffer-pos-x 0)
|
|
(set! result-lines 0)
|
|
(set! result-cols 0)
|
|
(set! highlighted-lines '())
|
|
(set! marked-lines '())
|
|
(set! history '())
|
|
(set! history-pos 0)
|
|
(set! active-keyboard-interrupt #f))
|
|
|
|
(define (get-param-as-str param-lst)
|
|
(let loop ((lst param-lst)
|
|
(str ""))
|
|
(if (null? lst)
|
|
str
|
|
(loop (cdr lst)
|
|
(string-append str " " (car lst))))))
|
|
|
|
(define-record-type standard-result-obj standard-result-obj
|
|
(make-standard-result-obj cursor-pos-y
|
|
cursor-pos-x
|
|
result-text
|
|
result)
|
|
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 (make-standard-result-obj 1 1 text-result
|
|
(car text-result)))
|
|
|
|
;;Standard-Receiver:
|
|
(define (standard-receiver-rec message)
|
|
(cond
|
|
((init-with-result-message? message)
|
|
(make-standard-result-obj
|
|
1 1
|
|
(layout-result-standard
|
|
(exp->string (init-with-result-message-result message))
|
|
(init-with-result-message-width message))
|
|
(init-with-result-message-result message)))
|
|
((next-command-message? message)
|
|
(let* ((result (eval-expression (message-command-string message)))
|
|
(result-string (exp->string result))
|
|
(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-print-object pos-y pos-x text '() '())))
|
|
((key-pressed-message? message)
|
|
(message-result-object message))
|
|
((restore-message? message)
|
|
(values))
|
|
((selection-message? message)
|
|
"")))
|
|
|
|
(define standard-view-plugin
|
|
(make-view-plugin standard-receiver-rec
|
|
(lambda (val) #t)))
|