1097 lines
31 KiB
Scheme
1097 lines
31 KiB
Scheme
;; ,load /home/demattia/studium/studienarbeit/scsh-nuit/scheme/nuit-engine.scm
|
|
|
|
|
|
;;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 bar-1 #f)
|
|
(define bar-2 #f)
|
|
(define command-frame-window #f)
|
|
(define command-window #f)
|
|
(define result-window #f)
|
|
|
|
(define shortcuts '("F1:Exit"
|
|
"F2:Repaint (after change of buffer size)"
|
|
"Ctrl+x o:Switch Buffer"
|
|
"Ctrl+x s:Insert/Select"
|
|
"Ctrl+x u:-/Unselect"
|
|
"PageUp - previous entry in result history"
|
|
"PageDown - next entry in result history"
|
|
"Ctrl+x r:Redo (Active Command)"
|
|
"CursorUp - previous entry in command history"
|
|
"CursorDown - next entry in command history"
|
|
"Ctrl+a:First Pos of Line"
|
|
"Ctrl+e:End of Line"
|
|
"Ctrl+k:Delete Line"))
|
|
|
|
;;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))
|
|
|
|
;;History
|
|
(define history '())
|
|
|
|
;;Position in the "elaborated" History
|
|
(define history-pos 0)
|
|
|
|
;;data-type for history.entries
|
|
(define-record-type history-entry history-entry
|
|
(make-history-entry command
|
|
parameters
|
|
result-object)
|
|
history-entry?
|
|
(command history-entry-command)
|
|
(parameters history-entry-parameters)
|
|
(result-object history-entry-result-object))
|
|
|
|
;;active command
|
|
(define active-command "")
|
|
|
|
;;sctive parameters
|
|
(define active-parameters "")
|
|
|
|
;;active result-object
|
|
(define current-result-object)
|
|
|
|
;;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)
|
|
|
|
;;This indicates if the last input was Ctrl-x
|
|
(define c-x-pressed #f)
|
|
|
|
|
|
;;Message-Types
|
|
;;---------------------
|
|
;;A new command was entered
|
|
;;->create a new "object"
|
|
(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))
|
|
|
|
;;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-model
|
|
key)
|
|
key-pressed-message?
|
|
(command-string key-pressed-command-string)
|
|
(result-model key-pressed-message-result-model)
|
|
(key key-pressed-message-key))
|
|
|
|
;;print
|
|
(define-record-type print-message print-message
|
|
(make-print-message command-string
|
|
object
|
|
width)
|
|
print-message?
|
|
(command-string print-message-command-string)
|
|
(object print-message-object)
|
|
(width print-message-width))
|
|
|
|
;;->this sort of data-type is returned by a print-message
|
|
(define-record-type print-object print-object
|
|
(make-print-object pos-y
|
|
pos-x
|
|
text
|
|
highlighted-lines
|
|
marked-lines)
|
|
(pos-y print-object-pos-y)
|
|
(pos-x print-object-pos-x)
|
|
(text print-object-text)
|
|
(highlighted-lines print-object-highlighted-lines)
|
|
(marked-lines print-object-marked-lines))
|
|
|
|
;;restore (when side-effects occur)
|
|
(define-record-type restore-message restore-message
|
|
(make-restore-message command-string
|
|
object)
|
|
restore-message?
|
|
(command-string restore-message-command-string)
|
|
(object restore-message-object))
|
|
|
|
;;request the selection
|
|
(define-record-type selection-message selection-message
|
|
(make-selection-message command-string
|
|
object)
|
|
selection-message?
|
|
(command-string selection-message-command-string)
|
|
(object selection-message-object))
|
|
|
|
;;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
|
|
(define-record-type receiver receiver
|
|
(make-receiver command rec)
|
|
receiver?
|
|
(command receiver-command)
|
|
(rec receiver-rec))
|
|
|
|
;;This list contains all the receivers that have been registered.
|
|
(define receivers '())
|
|
|
|
;;*************************************************************************
|
|
;;Actions
|
|
|
|
;;start the whole thing
|
|
(define (nuit)
|
|
(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))
|
|
|
|
;;handle input
|
|
(define (run)
|
|
|
|
'(set-interrupt-handler interrupt/keyboard
|
|
(lambda a
|
|
(set! active-keyboard-interrupt a)))
|
|
|
|
;;Loop
|
|
(paint)
|
|
(let loop ((ch (wait-for-input)))
|
|
(cond
|
|
;;The result of pressing these keys is independent of which
|
|
;;Buffer is active
|
|
;;Finish
|
|
((= ch key-f1)
|
|
(begin
|
|
(let ((restore-message (make-restore-message
|
|
active-command
|
|
current-result-object)))
|
|
(switch restore-message)
|
|
(restore-state))
|
|
(endwin)
|
|
(display "")))
|
|
|
|
((= 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))))
|
|
|
|
;; forward in result history
|
|
((= ch key-npage)
|
|
(history-forward)
|
|
(paint-result-window)
|
|
(loop (wait-for-input)))
|
|
|
|
;; back in result history
|
|
((= ch key-ppage)
|
|
(history-back)
|
|
(paint-result-window)
|
|
(loop (wait-for-input)))
|
|
|
|
;;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))
|
|
(begin
|
|
(focus-command-buffer!)
|
|
(paint-command-window-contents)
|
|
(set! command-buffer (move-cursor command-buffer))))
|
|
(set! c-x-pressed #f)
|
|
(loop (wait-for-input)))
|
|
|
|
;;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
|
|
(switch restore-message)
|
|
(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)
|
|
(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)
|
|
(paint-bar-2)
|
|
(paint-command-window-contents)
|
|
(set! command-buffer (move-cursor command-buffer))
|
|
(loop (wait-for-input))))
|
|
|
|
(else
|
|
(set! command-buffer (input command-buffer ch))
|
|
(werase (app-window-curses-win command-window))
|
|
(print-command-buffer (app-window-curses-win command-window)
|
|
command-buffer)
|
|
(set! command-buffer (move-cursor command-buffer))
|
|
(loop (wait-for-input))))))))))
|
|
|
|
(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 (init-windows!)
|
|
(init-screen)
|
|
(set! bar-1
|
|
(make-app-window 1 1
|
|
(- (COLS) 2) 2
|
|
#f))
|
|
(set! bar-2
|
|
(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)
|
|
#f))
|
|
(set! command-window
|
|
(make-app-window (+ (app-window-x command-frame-window) 1)
|
|
(+ (app-window-y command-frame-window) 1)
|
|
(- (app-window-width command-frame-window) 2)
|
|
(- (app-window-height command-frame-window) 2)
|
|
#f))
|
|
(set! result-window
|
|
(make-app-window 1 (+ (app-window-y bar-2) 3)
|
|
(- (COLS) 2)
|
|
(- (- (LINES) 6) (app-window-height command-frame-window))
|
|
#f))
|
|
(window-init-curses-win! bar-1)
|
|
(window-init-curses-win! bar-2)
|
|
(window-init-curses-win! command-frame-window)
|
|
(window-init-curses-win! command-window)
|
|
(window-init-curses-win! result-window)
|
|
(wclear (app-window-curses-win bar-1))
|
|
(wclear (app-window-curses-win bar-2))
|
|
(wclear (app-window-curses-win command-window))
|
|
(wclear (app-window-curses-win command-frame-window))
|
|
(wclear (app-window-curses-win result-window))
|
|
(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-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))
|
|
(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))
|
|
(set! command-buffer
|
|
(print-command-buffer (app-window-curses-win command-window)
|
|
command-buffer))
|
|
(wrefresh (app-window-curses-win command-window)))
|
|
|
|
(define (paint-result-window)
|
|
(wclear (app-window-curses-win result-window))
|
|
(box (app-window-curses-win result-window)
|
|
(ascii->char 0) (ascii->char 0))
|
|
(set! result-lines (- (app-window-height result-window) 2))
|
|
(set! result-cols (- (app-window-width result-window) 3))
|
|
(print-result-buffer result-window)
|
|
(wrefresh (app-window-curses-win result-window)))
|
|
|
|
(define (paint)
|
|
(init-windows!)
|
|
(paint-bar-1)
|
|
(paint-bar-2)
|
|
(paint-command-frame-window)
|
|
(paint-command-window-contents)
|
|
(paint-result-window)
|
|
(move-cursor command-buffer))
|
|
|
|
(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))
|
|
|
|
;;If the user presses enter the last line is interpreted as a command
|
|
;;which has to be executed.
|
|
(define (execute-command)
|
|
(let* ((com (list-ref (buffer-text command-buffer)
|
|
(- (length (buffer-text command-buffer)) 1)))
|
|
(com-par (extract-com-and-par com))
|
|
(command (car com-par))
|
|
(parameters (cdr com-par))
|
|
;;todo: parameters
|
|
(message (make-next-command-message
|
|
command parameters result-cols))
|
|
(model (switch message)))
|
|
(if (not (= history-pos 0))
|
|
(let ((hist-entry (make-history-entry active-command
|
|
active-parameters
|
|
current-result-object))
|
|
(active (make-history-entry command
|
|
(get-param-as-str parameters)
|
|
model)))
|
|
(if (< history-pos (length history))
|
|
(set! history (append history (list hist-entry)))
|
|
(set! history (append
|
|
(sublist history 0
|
|
(- (length history) 1))
|
|
(list hist-entry) (list active))))
|
|
(set! history-pos (length history)))
|
|
(let ((hist-entry (make-history-entry
|
|
command
|
|
(get-param-as-str parameters) model)))
|
|
(set! history (list hist-entry))
|
|
(set! history-pos 1)))
|
|
|
|
(set-buffer-text! command-buffer
|
|
(append (buffer-text command-buffer)
|
|
(list "")))
|
|
(set! active-command command)
|
|
(set! active-parameters (get-param-as-str parameters))
|
|
(set! current-result-object model)
|
|
(scroll-command-buffer)))
|
|
|
|
;;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
|
|
(lambda (str)
|
|
(let loop ((old str)
|
|
(new ""))
|
|
(if (= 0 (string-length old))
|
|
(cons new old)
|
|
(if (equal? #\space (string-ref old 0))
|
|
(if (= 1 (string-length old))
|
|
(cons new "")
|
|
(cons new (substring old 1 (string-length old))))
|
|
(if (equal? #\( (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
|
|
(lambda (str)
|
|
(let loop ((old str)
|
|
(new ""))
|
|
(if (= 0 (string-length old))
|
|
(cons new old)
|
|
(if (equal? #\( (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 (equal? #\) (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))
|
|
|
|
;;evaluate an expression given as a string
|
|
(define evaluate
|
|
(lambda (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)))
|
|
|
|
|
|
|
|
;;Message-Passing
|
|
;;switch manages that the messages are delivered in the correct way
|
|
(define switch
|
|
(lambda (message)
|
|
(let ((command ""))
|
|
(begin
|
|
(cond
|
|
((next-command-message? message)
|
|
(set! command (next-command-string message)))
|
|
((key-pressed-message? message)
|
|
(set! command (key-pressed-command-string message)))
|
|
((print-message? message)
|
|
(set! command (print-message-command-string message)))
|
|
((restore-message? message)
|
|
(set! command (restore-message-command-string message)))
|
|
((selection-message? message)
|
|
(set! command (selection-message-command-string message))))
|
|
(let ((receiver (get-receiver command)))
|
|
(if receiver
|
|
(receiver message)
|
|
(standard-receiver message)))))))
|
|
|
|
(define get-receiver
|
|
(lambda (command)
|
|
(let loop ((recs receivers))
|
|
(if (= 0 (length recs))
|
|
#f
|
|
(let* ((act-rec (car recs))
|
|
(act-com (receiver-command act-rec))
|
|
(act-rec-proc (receiver-rec act-rec)))
|
|
(if (equal? command act-com)
|
|
act-rec-proc
|
|
(loop (cdr recs))))))))
|
|
|
|
|
|
;;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
|
|
(lambda (string)
|
|
(let loop ((str string))
|
|
(if (equal? str "")
|
|
(values)
|
|
(let ((first-ch (string-ref str 0)))
|
|
(begin
|
|
(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
|
|
(lambda (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)))))
|
|
|
|
;;print the active-command window:
|
|
(define print-active-command-win
|
|
(lambda (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
|
|
"...")))
|
|
(begin
|
|
(mvwaddstr win 1 2 whole-text)
|
|
(wrefresh win)))
|
|
(begin
|
|
(mvwaddstr win 1 2 (string-append "Active Command: "
|
|
active-command))
|
|
(wrefresh win)))))))
|
|
|
|
|
|
|
|
;;print the lower window
|
|
(define (print-result-buffer result-window)
|
|
(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)))
|
|
(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-object))
|
|
(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
|
|
(lambda ()
|
|
(prepare-lines text-result result-lines pos-result)))
|
|
|
|
;;marked and highlighted lines
|
|
(define right-highlighted-lines
|
|
(lambda ()
|
|
(let loop ((old highlighted-lines)
|
|
(new '()))
|
|
(if (equal? '() 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
|
|
(lambda ()
|
|
(let loop ((old marked-lines)
|
|
(new '()))
|
|
(if (equal? '() 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
|
|
(lambda ()
|
|
(if (focus-on-command-buffer?)
|
|
(begin
|
|
(if (>= (buffer-pos-fin-ln command-buffer)
|
|
(buffer-num-lines command-buffer))
|
|
(set-buffer-pos-y! command-buffer
|
|
(buffer-num-lines command-buffer))
|
|
(set-buffer-pos-y! command-buffer
|
|
(buffer-pos-fin-ln command-buffer)))
|
|
(let ((posx (modulo (buffer-pos-col command-buffer)
|
|
(buffer-num-cols command-buffer))))
|
|
(set-buffer-pos-x! command-buffer posx)))
|
|
(begin
|
|
(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)))))
|
|
|
|
|
|
; ;;index of shortcuts at the bottom
|
|
; (define print-bar3
|
|
; (lambda (width)
|
|
; (let loop ((pos 0)
|
|
; (used-width 0)
|
|
; (act-line 1))
|
|
; (if (>= pos (length shortcuts))
|
|
; (begin
|
|
; (let* ((num-blanks (+ (- width used-width) 1))
|
|
; (last-string (make-string num-blanks #\space)))
|
|
; (mvwaddstr bar3 act-line (+ used-width 1) last-string))
|
|
; (wrefresh bar3))
|
|
; (let* ((act-string (list-ref shortcuts pos))
|
|
; (act-length (string-length act-string))
|
|
; (rest-width (- width used-width)))
|
|
; (if (= act-line 1)
|
|
; (if (<= (+ act-length 3) rest-width)
|
|
; (if (= used-width 0)
|
|
; (begin
|
|
; (mvwaddstr bar3 1 (+ used-width 1) act-string)
|
|
; (loop (+ pos 1) (+ used-width act-length) 1))
|
|
; (begin
|
|
; (mvwaddstr bar3 1 (+ used-width 1)
|
|
; (string-append " | " act-string))
|
|
; (loop (+ pos 1) (+ used-width (+ 3 act-length))
|
|
; 1)))
|
|
; (begin
|
|
; (let* ((num-blanks (+ rest-width 1))
|
|
; (last-string (make-string num-blanks #\space)))
|
|
; (mvwaddstr bar3 1 (+ used-width 1) last-string))
|
|
; (loop pos 0 2)))
|
|
; (if (<= (+ act-length 3) rest-width)
|
|
; (if (= used-width 0)
|
|
; (begin
|
|
; (mvwaddstr bar3 2 (+ used-width 1) act-string)
|
|
; (loop (+ pos 1) (+ used-width act-length) 2))
|
|
; (begin
|
|
; (mvwaddstr bar3 2 (+ used-width 1)
|
|
; (string-append " | " act-string))
|
|
; (loop (+ pos 1) (+ used-width (+ 3 act-length)) 2)))
|
|
; (begin
|
|
; (let* ((num-blanks (+ rest-width 1) )
|
|
; (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
|
|
(lambda ()
|
|
(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)))
|
|
(begin
|
|
(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
|
|
(lambda ()
|
|
(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)))
|
|
(begin
|
|
(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
|
|
(lambda (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
|
|
(lambda ()
|
|
(begin
|
|
(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-command "")
|
|
(set! active-parameters "")
|
|
(set! current-result-object init-std-res)
|
|
(set! active-keyboard-interrupt #f))))
|
|
|
|
;;Shortcuts-receiver:
|
|
;;-------------------
|
|
;;If the user enters the command "shortcuts" a list of the included
|
|
;;shortcuts is displayed
|
|
(define-record-type shortcut-result-obj shortcut-result-obj
|
|
(make-shortcut-result-obj a)
|
|
shortcut-result-object?
|
|
(a shortcut-result-object-a))
|
|
|
|
(define shortcut-receiver
|
|
(lambda (message)
|
|
(cond
|
|
((next-command-message? message)
|
|
(make-shortcut-result-obj #t))
|
|
((print-message? message)
|
|
(make-print-object 1 1 shortcuts '() '()))
|
|
((key-pressed-message? message)
|
|
(key-pressed-message-result-model message))
|
|
((restore-message? message)
|
|
(values))
|
|
((selection-message? message)
|
|
""))))
|
|
|
|
(define shortcut-rec (make-receiver "shortcuts" shortcut-receiver))
|
|
|
|
(set! receivers (cons shortcut-rec receivers))
|
|
|
|
|
|
|
|
;;Standard-Receiver
|
|
;;-----------------
|
|
|
|
;;Datatype representing the "standard-result-objects"
|
|
(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)))
|
|
|
|
(set! current-result-object init-std-res)
|
|
|
|
|
|
;;Standard-Receiver:
|
|
(define standard-receiver
|
|
(lambda (message)
|
|
(cond
|
|
((next-command-message? message)
|
|
(let* ((command (next-command-string message))
|
|
(result (evaluate command))
|
|
(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)))
|
|
((print-message? message)
|
|
(let* ((model (print-message-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)
|
|
result width)))
|
|
(make-print-object pos-y pos-x text '() '())))
|
|
((key-pressed-message? message)
|
|
(key-pressed-message-result-model message))
|
|
((restore-message? message)
|
|
(values))
|
|
((selection-message? message)
|
|
""))))
|
|
|
|
;;the result is the "answer" of scsh
|
|
(define layout-result-standard
|
|
(lambda (result-str result width)
|
|
(reverse (seperate-line result-str width))))
|
|
|
|
|
|
;useful helpers
|
|
(define get-marked-positions-1
|
|
(lambda (all-items marked-items)
|
|
(let loop ((count 0)
|
|
(result '()))
|
|
(if (>= count (length all-items))
|
|
result
|
|
(let ((act-item (list-ref all-items count)))
|
|
(if (member act-item marked-items)
|
|
(loop (+ count 1)
|
|
(append result (list (+ count 1))))
|
|
(loop (+ count 1) result)))))))
|
|
|
|
|
|
(define get-marked-positions-2
|
|
(lambda (all-items marked-items)
|
|
(let loop ((count 0)
|
|
(result '()))
|
|
(if (>= count (length all-items))
|
|
result
|
|
(let ((act-item (list-ref all-items count)))
|
|
(if (member act-item marked-items)
|
|
(loop (+ count 1)
|
|
(append result (list (+ count 2))))
|
|
(loop (+ count 1) result)))))))
|
|
|
|
(define get-marked-positions-3
|
|
(lambda (all-items marked-items)
|
|
(let loop ((count 0)
|
|
(result '()))
|
|
(if (>= count (length all-items))
|
|
result
|
|
(let ((act-item (list-ref all-items count)))
|
|
(if (member act-item marked-items)
|
|
(loop (+ count 1)
|
|
(append result (list (+ count 3))))
|
|
(loop (+ count 1) result)))))))
|
|
|
|
;;expression as string
|
|
(define exp->string
|
|
(lambda (exp)
|
|
(let ((exp-port (open-output-string)))
|
|
(begin
|
|
(write exp exp-port)
|
|
(get-output-string exp-port)))))
|
|
|
|
;;seperate a long line into pieces, each fitting into a smaller line.
|
|
(define seperate-line
|
|
(lambda (line width)
|
|
(let loop ((new '())
|
|
(old line))
|
|
(if (> width (string-length old))
|
|
(if (= 0 (string-length old))
|
|
(if (equal? new '())
|
|
'("")
|
|
new)
|
|
(append (list old) new))
|
|
(let ((next-line (substring old 0 width))
|
|
(rest-old (substring old width (string-length old))))
|
|
(loop (cons next-line new) rest-old))))))
|
|
|
|
|
|
(define get-param-as-str
|
|
(lambda (param-lst)
|
|
(let loop ((lst param-lst)
|
|
(str ""))
|
|
(if (null? lst)
|
|
str
|
|
(loop (cdr lst)
|
|
(string-append str " " (car lst)))))))
|