;; ,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)))