diff --git a/scheme/cd.scm b/scheme/cd.scm new file mode 100644 index 0000000..92e91a6 --- /dev/null +++ b/scheme/cd.scm @@ -0,0 +1,194 @@ +;;cd +;;This command can be used on all platforms because it uses the +;;scsh-Function "chdir" + +(define-record-type cd-result-object cd-result-object + (make-cd-result-object pos-y + pos-x + file-list + result-text + working-directory + width + initial-wd + marked-items + res-marked-items) + cd-result-object? + (pos-y cd-result-object-pos-y) + (pos-x cd-result-object-pos-x) + (file-list cd-result-object-file-list) + (result-text cd-result-object-result-text) + (working-directory cd-result-object-working-directory) + (width cd-result-object-width) + (initial-wd cd-result-object-initial-wd) + (marked-items cd-result-object-marked-items) + (res-marked-items cd-result-object-res-marked-items)) + +;;Layout of the result of cd +(define layout-result-cd + (lambda (result-str result width) + (begin + (let ((printed-file-list (print-file-list result)) + (directory (cwd)) + (heading "")) + (begin + (if (<= (string-length directory) (- width 27)) + (set! heading (string-append "Directory-Content of " + directory " :")) + (let ((dir-string (substring directory + (- (string-length directory) + (- width 27)) + (string-length directory)))) + (set! heading (string-append "Directory-Content of ..." + dir-string)))) + (append (list heading) printed-file-list)))))) + +;;One File per-line +;;In case the object is a directory "/" is added +(define print-file-list + (lambda (file-list) + (let loop ((old file-list) + (new '())) + (if (equal? '() old) + new + (let ((hd (list-ref old 0)) + (tl (cdr old))) + (if (file-directory? hd) + (let ((new-str (string-append " " hd "/"))) + (loop tl (append new (list new-str)))) + (loop tl (append new (list (string-append " " hd)))))))))) + +;;selection->descend +(define selected-cd + (lambda (model) + (let ((ln (cd-result-object-pos-y model)) + (wd (cd-result-object-working-directory model))) + (begin + (chdir wd) + (if (or (>= ln (+ (length (cd-result-object-result-text model)) 1)) + (<= ln 1)) + model + (let* ((text (cd-result-object-result-text model)) + (ent (list-ref text (- ln 1))) + (len (string-length ent)) + (last-char (substring ent (- len 1) len)) + (rest (substring ent 1 (- len 1)))) + (if (equal? last-char "/") + (begin + (chdir rest) + (let* ((new-result (evaluate "(directory-files)")) + (new-result-string (exp->string new-result)) + (width (cd-result-object-width model)) + (new-text (layout-result-cd + new-result-string new-result width)) + (new-model (make-cd-result-object + 2 + 1 + new-result + new-text + (cwd) + width + (cd-result-object-initial-wd model) + (cd-result-object-marked-items model) + (cd-result-object-res-marked-items + model)))) + new-model)) + model))))))) + + +(define cd-receiver + (lambda (message) + (cond + ((next-command-message? message) + (let* ((command (next-command-string message)) + (parameters (next-command-message-parameters message)) + (result #f) + (width (next-command-message-width message))) + + (begin + (if (null? parameters) + (begin + (set! result (list "forgot parameters?")) + (let* ((text + (layout-result-standard "forgot parameters?" + result width)) + (std-obj + (make-cd-result-object 1 1 result text (cwd) width + (cwd) '() '()))) + std-obj)) + + (begin + (evaluate (string-append "(chdir " + (exp->string (car parameters)) + " )")) + (set! result (evaluate "(directory-files)")) + (let* ((result-string (exp->string result)) + (width (next-command-message-width message)) + (text + (layout-result-cd result-string result width)) + (cd-obj + (make-cd-result-object 2 1 result text (cwd) width + (cwd) '() '()))) + cd-obj)))))) + ((print-message? message) + (let* ((model (print-message-object message)) + (pos-y (cd-result-object-pos-y model)) + (pos-x (cd-result-object-pos-x model)) + (text (cd-result-object-result-text model)) + (marked-pos (get-marked-positions-2 + (cd-result-object-file-list model) + (cd-result-object-marked-items model)))) + (make-print-object pos-y pos-x text (list pos-y) marked-pos))) + ((key-pressed-message? message) + (let* ((model (key-pressed-message-result-model message)) + (key (key-pressed-message-key message))) + (cond + ((= key key-up) + (let ((posy (cd-result-object-pos-y model))) + (if (<= posy 2) + model + (let* ((new-posy (- posy 1)) + (new-model (make-cd-result-object + new-posy + (cd-result-object-pos-x model) + (cd-result-object-file-list model) + (cd-result-object-result-text model) + (cd-result-object-working-directory model) + (cd-result-object-width model) + (cd-result-object-initial-wd model) + (cd-result-object-marked-items model) + (cd-result-object-res-marked-items model)))) + new-model)))) + + ((= key key-down) + (let ((posy (cd-result-object-pos-y model)) + (num-lines (length + (cd-result-object-result-text model)))) + (if (>= posy num-lines) + model + (let* ((new-posy (+ posy 1)) + (new-model (make-cd-result-object + new-posy + (cd-result-object-pos-x model) + (cd-result-object-file-list model) + (cd-result-object-result-text model) + (cd-result-object-working-directory model) + (cd-result-object-width model) + (cd-result-object-initial-wd model) + (cd-result-object-marked-items model) + (cd-result-object-res-marked-items model)))) + new-model)))) + + ((= key 10) + (selected-cd model)) + (else model)))) + + + ((restore-message? message) + values) + ((selection-message? message) + "")))) + + +(define cd-rec (make-receiver "cd" cd-receiver)) + +(set! receivers (cons cd-rec receivers)) \ No newline at end of file diff --git a/scheme/directory-files.scm b/scheme/directory-files.scm index c5383f4..a2b5238 100644 --- a/scheme/directory-files.scm +++ b/scheme/directory-files.scm @@ -66,62 +66,66 @@ ;;Auswahl->absteigen (define selected-dirfiles (lambda (model) - (let ((ln (dirfiles-result-object-pos-y model))) - (if (or (>= ln (+ (length (dirfiles-result-object-result-text model)) 1)) - (<= ln 1)) - model - (if (= ln 2) - (if (not (equal? "/" (cwd))) - (begin - (chdir "..") - (let* ((new-result (evaluate "(directory-files)")) - (new-result-string (exp->string new-result)) - (width (dirfiles-result-object-width model)) - (new-text (layout-result-dirfiles - new-result-string new-result width)) - (new-model (make-dirfiles-result-object - 2 - 1 - new-result - new-text - (cwd) - width - (dirfiles-result-object-initial-wd - model) - (dirfiles-result-object-marked-items - model) - (dirfiles-result-object-res-marked-items - model)))) - new-model)) - model) - (let* ((text (dirfiles-result-object-result-text model)) - (ent (list-ref text (- ln 1))) - (len (string-length ent)) - (last-char (substring ent (- len 1) len)) - (rest (substring ent 1 (- len 1)))) - (if (equal? last-char "/") - (begin - (chdir rest) - (let* ((new-result (evaluate "(directory-files)")) - (new-result-string (exp->string new-result)) - (width (dirfiles-result-object-width model)) - (new-text (layout-result-dirfiles - new-result-string new-result width)) - (new-model (make-dirfiles-result-object - 2 - 1 - new-result - new-text - (cwd) - width - (dirfiles-result-object-initial-wd - model) - (dirfiles-result-object-marked-items - model) - (dirfiles-result-object-res-marked-items - model)))) - new-model)) - model))))))) + (let ((ln (dirfiles-result-object-pos-y model)) + (wd (dirfiles-result-object-working-directory model))) + (begin (chdir wd) + (if (or (>= ln (+ (length + (dirfiles-result-object-result-text model)) 1)) + (<= ln 1)) + model + (if (= ln 2) + (if (not (equal? "/" (cwd))) + (begin + (chdir "..") + (let* ((new-result (evaluate "(directory-files)")) + (new-result-string (exp->string new-result)) + (width (dirfiles-result-object-width model)) + (new-text (layout-result-dirfiles + new-result-string + new-result width)) + (new-model (make-dirfiles-result-object + 2 + 1 + new-result + new-text + (cwd) + width + (dirfiles-result-object-initial-wd + model) + (dirfiles-result-object-marked-items + model) + (dirfiles-result-object-res-marked-items + model)))) + new-model)) + model) + (let* ((text (dirfiles-result-object-result-text model)) + (ent (list-ref text (- ln 1))) + (len (string-length ent)) + (last-char (substring ent (- len 1) len)) + (rest (substring ent 1 (- len 1)))) + (if (equal? last-char "/") + (begin + (chdir rest) + (let* ((new-result (evaluate "(directory-files)")) + (new-result-string (exp->string new-result)) + (width (dirfiles-result-object-width model)) + (new-text (layout-result-dirfiles + new-result-string new-result width)) + (new-model (make-dirfiles-result-object + 2 + 1 + new-result + new-text + (cwd) + width + (dirfiles-result-object-initial-wd + model) + (dirfiles-result-object-marked-items + model) + (dirfiles-result-object-res-marked-items + model)))) + new-model)) + model)))))))) ;;Receiver für directory-files @@ -131,7 +135,7 @@ ((next-command-message? message) (let* ((command (next-command-string message)) - (result (evaluate command)) + (result (evaluate "(directory-files)")) (result-string (exp->string result)) (width (next-command-message-width message)) (text (layout-result-dirfiles result-string result width)) @@ -144,7 +148,7 @@ (posy (dirfiles-result-object-pos-y model)) (posx (dirfiles-result-object-pos-x model)) (text (dirfiles-result-object-result-text model)) - (marked-pos (get-marked-positions + (marked-pos (get-marked-positions-3 (dirfiles-result-object-file-list model) (dirfiles-result-object-marked-items model)))) (make-print-object posy posx text (list posy) marked-pos))) @@ -211,30 +215,34 @@ (all-items (dirfiles-result-object-file-list model))) (if (<= actual-pos 2) model - (let* ((actual-item (list-ref all-items (- actual-pos 3))) - (actual-res-item (string-append (cwd) "/" actual-item))) - (if (member actual-res-item marked-items) - model - (let* ((new-res-marked-items (append res-marked-items - (list - actual-res-item))) - (new-marked-items (append marked-items - (list actual-item))) - (new-model (make-dirfiles-result-object - (dirfiles-result-object-pos-y model) - (dirfiles-result-object-pos-x model) - (dirfiles-result-object-file-list - model) - (dirfiles-result-object-result-text - model) - (dirfiles-result-object-working-directory - model) - (dirfiles-result-object-width model) - (dirfiles-result-object-initial-wd - model) - new-marked-items - new-res-marked-items))) - new-model)))))) + (let ((actual-item (list-ref all-items (- actual-pos 3))) + (actual-res-item #f)) + (begin + (if (not (equal? (cwd) "/")) + (set! actual-res-item (string-append (cwd) "/" actual-item)) + (set! actual-res-item (string-append "/" actual-item))) + (if (member actual-res-item marked-items) + model + (let* ((new-res-marked-items (append res-marked-items + (list + actual-res-item))) + (new-marked-items (append marked-items + (list actual-item))) + (new-model (make-dirfiles-result-object + (dirfiles-result-object-pos-y model) + (dirfiles-result-object-pos-x model) + (dirfiles-result-object-file-list + model) + (dirfiles-result-object-result-text + model) + (dirfiles-result-object-working-directory + model) + (dirfiles-result-object-width model) + (dirfiles-result-object-initial-wd + model) + new-marked-items + new-res-marked-items))) + new-model))))))) ;;Ctrl+u -> aus Auswahl rausnehmen ((= key 21) @@ -304,8 +312,13 @@ (else values)))) -(define dir-files-rec - (make-receiver "(directory-files)" dir-files-receiver)) +(define dir-files-rec1 + (make-receiver "directory-files" dir-files-receiver)) -(define receivers (cons dir-files-rec '())) +(set! receivers (cons dir-files-rec1 receivers)) + +(define dir-files-rec2 + (make-receiver "ls" dir-files-receiver)) + +(set! receivers (cons dir-files-rec2 receivers)) diff --git a/scheme/find.scm b/scheme/find.scm new file mode 100644 index 0000000..c51a773 --- /dev/null +++ b/scheme/find.scm @@ -0,0 +1,185 @@ +;;find +;;This extension uses the unix-tool "find". You can only use this command in +;;if "find" is present in your environment. + +;;Datatype for the representation of a find-object +(define-record-type find-result-object find-result-object + (make-find-result-object pos-y + pos-x + file-list + result-text + parameters + width + marked-items + res-marked-items) + find-result-object? + (pos-y find-res-obj-pos-y) + (pos-x find-res-obj-pos-x) + (file-list find-res-obj-file-list) + (result-text find-res-obj-result-text) + (parameters find-res-obj-parameters) + (width find-res-obj-width) + (marked-items find-res-obj-marked-items) + (res-marked-items find-res-obj-res-marked-items)) + + +;;Layout for Command "find" +(define layout-result-find + (lambda (result-str result width parameters) + (begin + (let ((heading "")) + (begin + (set! result-str (map (lambda (s) (string-append " " s)) result-str)) + (if (<= (string-length parameters) (- width 10)) + (set! heading (string-append "find " + parameters " :")) + (let ((dir-string (substring parameters + (- (string-length parameters) + (- width 10)) + (string-length parameters)))) + (set! heading (string-append "find" dir-string "...")))) + (append (list heading) result-str)))))) + + + + + +(define find-receiver + (lambda (message) + (cond + ((next-command-message? message) + (let* ((command (next-command-string message)) + (parameter (next-command-message-parameters message)) + (parameters (get-param-as-str parameter)) + (result (evaluate + (string-append "(run/sexps (find" parameters "))"))) + (result-string (map exp->string result)) + (width (next-command-message-width message))) + (let* ((text + (layout-result-find result-string result width parameters)) + (find-obj + (make-find-result-object 2 1 result text parameter width + '() '()))) + find-obj))) + + ((print-message? message) + (let* ((model (print-message-object message)) + (pos-y (find-res-obj-pos-y model)) + (pos-x (find-res-obj-pos-x model)) + (text (find-res-obj-result-text model)) + (marked-pos (get-marked-positions-2 + (find-res-obj-file-list model) + (find-res-obj-marked-items model)))) + (make-print-object pos-y pos-x text (list pos-y) marked-pos))) + + ((key-pressed-message? message) + (let* ((model (key-pressed-message-result-model message)) + (key (key-pressed-message-key message))) + (cond + + ((= key key-up) + (let ((posy (find-res-obj-pos-y model))) + (if (<= posy 2) + model + (let* ((new-posy (- posy 1)) + (new-model (make-find-result-object + new-posy + (find-res-obj-pos-x model) + (find-res-obj-file-list model) + (find-res-obj-result-text model) + (find-res-obj-parameters model) + (find-res-obj-width model) + (find-res-obj-marked-items model) + (find-res-obj-res-marked-items model)))) + new-model)))) + + ((= key key-down) + (let ((posy (find-res-obj-pos-y model)) + (num-lines (length + (find-res-obj-result-text model)))) + (if (>= posy num-lines) + model + (let* ((new-posy (+ posy 1)) + (new-model (make-find-result-object + new-posy + (find-res-obj-pos-x model) + (find-res-obj-file-list model) + (find-res-obj-result-text model) + (find-res-obj-parameters model) + (find-res-obj-width model) + (find-res-obj-marked-items model) + (find-res-obj-res-marked-items model)))) + new-model)))) + + ;;Ctrl+s -> select + ((= key 19) + (let* ((marked-items (find-res-obj-marked-items model)) + (res-marked-items (find-res-obj-res-marked-items + model)) + (actual-pos (find-res-obj-pos-y model)) + (all-items (find-res-obj-file-list model))) + (if (<= actual-pos 1) + model + (let ((actual-item (list-ref all-items (- actual-pos 2))) + (actual-res-item #f)) + (begin + (if (member actual-res-item marked-items) + model + (let* ((new-res-marked-items (append res-marked-items + (list + actual-res-item))) + (new-marked-items (append marked-items + (list actual-item))) + (new-model (make-find-result-object + (find-res-obj-pos-y model) + (find-res-obj-pos-x model) + (find-res-obj-file-list model) + (find-res-obj-result-text model) + (find-res-obj-parameters model) + (find-res-obj-width model) + new-marked-items + new-res-marked-items))) + new-model))))))) + + ;;Ctrl+u -> unselect + ((= key 21) + (let* ((marked-items (find-res-obj-marked-items model)) + (actual-pos (find-res-obj-pos-y model)) + (all-items (find-res-obj-file-list model))) + (if (<= actual-pos 1) + model + (let* ((actual-item (list-ref all-items (- actual-pos 2))) + (rest (member actual-item marked-items))) + (if (not rest) + model + (let* ((after-item (length rest)) + (all-items (length marked-items)) + (before-item (sublist marked-items + 0 + (- all-items + after-item ))) + (new-marked-items (append before-item + (list-tail rest 1))) + (new-model (make-find-result-object + (find-res-obj-pos-y model) + (find-res-obj-pos-x model) + (find-res-obj-file-list model) + (find-res-obj-result-text model) + (find-res-obj-parameters model) + (find-res-obj-width model) + new-marked-items + '()))) + new-model)))))) + (else model)))) + + ((restore-message? message) + values) + ((selection-message? message) + (let* ((model (selection-message-object message)) + (marked-items (find-res-obj-marked-items model))) + (string-append "'" (exp->string + (map exp->string marked-items)))))))) + +(define find-rec (make-receiver "find" find-receiver)) + +(set! receivers (cons find-rec receivers)) \ No newline at end of file diff --git a/scheme/handle-fatal-error.scm b/scheme/handle-fatal-error.scm index 63ed459..2f24891 100644 --- a/scheme/handle-fatal-error.scm +++ b/scheme/handle-fatal-error.scm @@ -43,7 +43,8 @@ ((call-with-current-continuation (lambda (k) (with-handler (lambda (condition more) - (if (error? condition) + (if (or (error? condition) + (warning? condition)) (call-with-current-continuation (lambda (decline) (k (lambda () (handler condition decline)))))) diff --git a/scheme/nuit-engine.scm b/scheme/nuit-engine.scm index 57b4814..9ac18e3 100644 --- a/scheme/nuit-engine.scm +++ b/scheme/nuit-engine.scm @@ -1,3 +1,6 @@ +;; ,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: @@ -18,11 +21,14 @@ (define result-win) (define shortcuts '("F1:Exit" + "F2:Repaint (after change of buffer size)" "Ctrl+d:Switch Buffer" "Ctrl+s:Insert/Select" "Ctrl+u:-/Unselect" - "Ctrl+p:History->prev" - "Ctrl+n:History->next" + "Ctrl+p:Result-History->prev" + "Ctrl+n:Result-History->next" + "Ctrl+f:Command-History->forward" + "Ctrl+b:Command-History->back" "Ctrl+a:First Pos" "Ctrl+e:End")) @@ -67,7 +73,7 @@ ;;state of the lower window (Result-Window) ;;---------------------------- ;;Text -(define text-result (list "Start entering commands.")) +(define text-result (list "Type 'shortcuts' for help")) ;;line of the result-window (define pos-result 0) @@ -111,18 +117,26 @@ ;;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) ;;Message-Types ;;--------------------- @@ -152,10 +166,12 @@ ;;print (define-record-type print-message print-message (make-print-message command-string - object) + object + width) print-message? (command-string print-message-command-string) - (object print-message-object)) + (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 @@ -195,9 +211,17 @@ (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 + (lambda () + (run))) + ;;handle input (define run (lambda () @@ -210,6 +234,12 @@ (set! bar3 (newwin 0 0 0 0)) (set! command-win (newwin 0 0 0 0)) (set! result-win (newwin 0 0 0 0)) + + ;;Handling Keyboard-interrupts + ;;If a keyboard-interrupt occurs it is stored in "active-keyboard-interrupt" + (set-interrupt-handler interrupt/keyboard + (lambda a + (set! active-keyboard-interrupt a))) ;;Loop (let loop ((ch (paint))) @@ -223,8 +253,14 @@ (let ((restore-message (make-restore-message active-command current-result-object))) - (switch restore-message)) - (endwin))) + (switch restore-message) + (restore-state)) + (endwin) + (display ""))) + + ((= ch key-f2) + (endwin) + (run)) ;;Ctrl+f -> switch buffer ((= ch 4) @@ -253,7 +289,9 @@ (begin (execute-command) (set! command-history-pos (- (length text-command) 1)) - (loop (paint)))) + ;(loop (paint)))) + (endwin) + (run))) @@ -320,47 +358,49 @@ (lambda () (begin (init-screen) - (cbreak) - (let* ((bar1-y 0) - (bar1-x 0) - (bar1-h 3) - (bar1-w (COLS)) - (bar2-y (round (/ (LINES) 3))) - (bar2-x 0) + ;(cbreak) + (let* ((bar1-y 1) + (bar1-x 1) + (bar1-h 2) + (bar1-w (- (COLS) 2)) + (bar2-y (+ (round (/ (LINES) 3)) 2)) + (bar2-x 1) (bar2-h 3) - (bar2-w (COLS)) - (comwin-y 3) - (comwin-x 0) - (comwin-h (- bar2-y 3)) - (comwin-w (COLS)) + (bar2-w (- (COLS) 2)) + (comwin-y 2) + (comwin-x 1) + (comwin-h (- bar2-y 2)) + (comwin-w (- (COLS) 2)) (reswin-y (+ bar2-y 3)) - (reswin-x 0) - (reswin-h (- (- (- (LINES) 6) comwin-h) 4)) - (reswin-w (COLS)) - (bar3-y (+ reswin-y reswin-h)) - (bar3-x 0) - (bar3-h 4) - (bar3-w (COLS))) + (reswin-x 1) + (reswin-h (- (- (LINES) 6) comwin-h)) + (reswin-w (- (COLS) 2))) + ; (bar3-y (+ reswin-y reswin-h)) +; (bar3-x 0) +; (bar3-h 4) +; (bar3-w (COLS))) (wclear bar1) (wclear bar2) (wclear command-win) (wclear result-win) - (wclear bar3) +; (wclear bar3) (clear) (set! bar1 (newwin bar1-h bar1-w bar1-y bar1-x)) (set! bar2 (newwin bar2-h bar2-w bar2-y bar2-x)) (set! command-win (newwin comwin-h comwin-w comwin-y comwin-x)) (set! result-win (newwin reswin-h reswin-w reswin-y reswin-x)) - (set! bar3 (newwin bar3-h bar3-w bar3-y bar3-x)) - - (box bar1 (ascii->char 0) (ascii->char 0)) - (mvwaddstr bar1 1 1 "Command") + ;(set! bar3 (newwin bar3-h bar3-w bar3-y bar3-x)) + + (box standard-screen (ascii->char 0) (ascii->char 0)) + (refresh) + ;(box bar1 (ascii->char 0) (ascii->char 0)) + (mvwaddstr bar1 0 1 "SCSH-NUIT") (wrefresh bar1) - (box bar2 (ascii->char 0) (ascii->char 0)) - (mvwaddstr bar2 1 1 "Result") - (wrefresh bar2) + + ;(mvwaddstr bar2 1 1 active-command) + ;(wrefresh bar2) (box command-win (ascii->char 0) (ascii->char 0)) (set! command-lines (- comwin-h 2)) (set! command-cols (- comwin-w 3)) @@ -384,11 +424,14 @@ (set! result-cols (- reswin-w 3)) (print-result-buffer result-win) (wrefresh result-win) - (box bar3 (ascii->char 0) (ascii->char 0)) - (wattron bar3 (A-REVERSE)) - (print-bar3 (- reswin-w 3)) - (wstandend bar3) - (wrefresh bar3) + ;(box bar3 (ascii->char 0) (ascii->char 0)) + ;(wattron bar3 (A-REVERSE)) + ;(print-bar3 (- reswin-w 3)) + ;(wstandend bar3) + ;(wrefresh bar3) + + (box bar2 (ascii->char 0) (ascii->char 0)) + (print-active-command-win bar2 bar2-w) (set! command-buffer (cur-right-pos command-win result-win comwin-h reswin-h command-buffer)) @@ -415,8 +458,11 @@ (set! can-write-command can-write) (set! command-history-pos history-pos))) + + (noecho) (keypad bar1 #t) + (set! active-keyboard-interrupt #f) (let ((ch (wgetch bar1))) (echo) ch @@ -427,15 +473,22 @@ ;;which has to be executed. (define execute-command (lambda () - (let* ((command (list-ref text-command (- (length text-command) 1))) - ;;todo: parameters - (message (make-next-command-message command '() result-cols)) + (let* ((com (list-ref text-command (- (length text-command) 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))) (begin (if (not (= history-pos 0)) (let ((hist-entry (make-history-entry active-command + active-parameters current-result-object)) - (active (make-history-entry command model))) + (active (make-history-entry command + (get-param-as-str parameters) + model))) (begin (if (< history-pos (length history)) (set! history (append history (list hist-entry))) @@ -444,16 +497,54 @@ (- (length history) 1)) (list hist-entry) (list active)))) (set! history-pos (length history)))) - (let ((hist-entry (make-history-entry command model))) + (let ((hist-entry (make-history-entry + command + (get-param-as-str parameters) model))) (begin (set! history (list hist-entry)) (set! history-pos 1)))) (set! text-command (append text-command (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)))) + (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 (lambda () @@ -554,12 +645,36 @@ (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 (lambda (reswin) (let* ((print-message (make-print-message active-command - current-result-object)) + current-result-object + command-cols)) (model (switch print-message)) (text (print-object-text model)) (pos-y (print-object-pos-y model)) @@ -579,26 +694,42 @@ (if (> pos result-lines) values (let ((line (list-ref lines (- pos 1)))) - (if (and (member pos highlighted-lines) - (= active-buffer 2)) - (begin - (wattron reswin (A-REVERSE)) - (mvwaddstr reswin pos 1 line) - (wattrset reswin (A-NORMAL)) - (wrefresh reswin) - (loop (+ pos 1))) - (if (member pos marked-lines) - (begin - (wattron reswin (A-BOLD)) - (mvwaddstr reswin pos 1 line) - (wattrset reswin (A-NORMAL)) - (wrefresh reswin) - (loop (+ pos 1))) - (begin - (mvwaddstr reswin pos 1 line) - (wrefresh reswin) - (loop (+ pos 1))))))))))))) - + (begin + (if (not (standard-result-obj? current-result-object)) + (set! line + (if (>= (string-length line) (- result-cols 2)) + (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) + (= active-buffer 2)) + (begin + (wattron reswin (A-REVERSE)) + (mvwaddstr reswin pos 1 line) + (wattrset reswin (A-NORMAL)) + (wrefresh reswin) + (loop (+ pos 1))) + (if (member pos marked-lines) + (begin + (wattron reswin (A-BOLD)) + (mvwaddstr reswin pos 1 line) + (wattrset reswin (A-NORMAL)) + (wrefresh reswin) + (loop (+ pos 1))) + (begin + (mvwaddstr reswin pos 1 line) + (wrefresh reswin) + (loop (+ pos 1)))))))))))))) + ;;visible lines (define get-right-result-lines (lambda () @@ -668,51 +799,51 @@ (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))))))))) +; ;;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))))))))) @@ -723,14 +854,12 @@ 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) - (set! text-command (append - (sublist text-command 0 - (- (length text-command) 1)) - (list entry-com))) (if (> history-pos 1) (set! history-pos (- history-pos 1)))))))) @@ -738,24 +867,17 @@ ;;one step forward (define history-forward (lambda () - (if (= history-pos (length history) ) - (set! text-command (append - (sublist text-command 0 - (- (length text-command) 1)) - (list ""))) (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! text-command (append - (sublist text-command 0 - (- (length text-command) 1)) - (list entry-com))) (set! active-command entry-com) + (set! active-parameters entry-par) (set! current-result-object entry-res-obj) - (set! history-pos (+ history-pos 1)))))))) + (set! history-pos (+ history-pos 1))))))) (define sublist (lambda (l pos k) @@ -764,6 +886,67 @@ (- (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-command (list "Welcome in the scsh-ncurses-ui!" "")) + (set! pos-command 2) + (set! pos-command-col 2) + (set! pos-command-fin-ln 2) + (set! command-buffer-pos-y 2) + (set! command-buffer-pos-x 2) + (set! command-lines 0) + (set! command-cols 0) + (set! can-write-command #t) + (set! command-history-pos 1) + (set! command-buffer #f) + (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! active-buffer 1) + (set! history '()) + (set! history-pos 0) + (set! active-command "") + (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 ;;----------------- @@ -771,13 +954,16 @@ (define-record-type standard-result-obj standard-result-obj (make-standard-result-obj cursor-pos-y cursor-pos-x - result-text) + 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-text standard-result-obj-result-text) + (result standard-result-obj-result)) -(define init-std-res (make-standard-result-obj 1 1 text-result)) +(define init-std-res (make-standard-result-obj 1 1 text-result + (car text-result))) (set! current-result-object init-std-res) @@ -794,13 +980,16 @@ (let* ((text (layout-result-standard result-string result width)) (std-obj - (make-standard-result-obj 1 1 text))) + (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)) - (text (standard-result-obj-result-text 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)) @@ -816,7 +1005,19 @@ ;useful helpers -(define get-marked-positions +(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 '())) @@ -828,7 +1029,6 @@ (append result (list (+ count 3)))) (loop (+ count 1) result))))))) - ;;expression as string (define exp->string (lambda (exp) @@ -837,9 +1037,6 @@ (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) @@ -856,3 +1053,14 @@ (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))))))) + + + diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm index d27f22d..1acd5c1 100644 --- a/scheme/nuit-packages.scm +++ b/scheme/nuit-packages.scm @@ -1,5 +1,5 @@ (define-interface nuit-interface - (export run)) + (export nuit)) (define-structure nuit nuit-interface (open scheme-with-scsh @@ -13,4 +13,6 @@ rt-modules) (files nuit-engine handle-fatal-error - directory-files)) + directory-files + find + cd))