diff --git a/scheme/browse-directory-list.scm b/scheme/browse-directory-list.scm index 6fb2129..3ab4774 100644 --- a/scheme/browse-directory-list.scm +++ b/scheme/browse-directory-list.scm @@ -38,42 +38,34 @@ (res-marked-items browse-dir-list-res-obj-res-marked-items) (c-x-pressed browse-dir-list-res-obj-c-x-pressed)) - -;;Layout of the directory-tree-browser -(define layout-result-browse-dir-list - (lambda (result-str result width directory) - (let ((printed-file-list (print-file-list-1 result directory))) - (append - (list - (if (<= (string-length directory) (- width 25)) - (string-append "Paths relative to " directory " :") - (let ((dir-string (substring directory - (- (string-length directory) +(define (layout-dir-list files wdir width) + (let ((marked-files (mark-special-files wdir files))) + (append + (list + (if (<= (string-length wdir) (- width 25)) + (string-append "Paths relative to " wdir " :") + (let ((dir-string (substring wdir + (- (string-length wdir) (- width 25)) - (string-length directory)))) - (string-append "Paths relative to ..." - dir-string)))) - printed-file-list)))) - - -;;One File per-line -;;In case the object is a directory "/" is added -(define print-file-list-1 - (lambda (file-list dir) - (let loop ((old file-list) - (new '())) - (if (equal? '() old) - new - (let* ((hd (list-ref old 0)) - (hd-path (string-append dir "/" hd)) - (tl (cdr old))) - (if (file-exists? hd-path) - (if (file-directory? hd-path) - (let ((new-str (string-append " " hd "/"))) - (loop tl (append new (list new-str)))) - (loop tl (append new (list (string-append " " hd))))) - (loop tl new))))))) + (string-length wdir)))) + (string-append "Paths relative to ..." + dir-string)))) + marked-files))) +(define (mark-special-files dir files) + (map (lambda (file) + (let ((complete-name (string-append dir "/" file))) + (cond + ((file-directory? complete-name) + (string-append " " file "/")) + ((file-executable? complete-name) + (string-append "*" file)) + ((file-symlink? complete-name) + (string-append "@" file)) + (else + (string-append " " file))))) + files)) + ;;selection->descend (define selected-browse-dir-list (lambda (model) @@ -90,12 +82,10 @@ (if (not (equal? "/" (cwd))) (begin (chdir "..") - (let* ((new-result (evaluate "(directory-files)")) - (new-result-string (exp->string new-result)) + (let* ((new-result (directory-files)) (width (browse-dir-list-res-obj-width model)) - (new-text (layout-result-browse-dir-list - new-result-string - new-result width (cwd))) + (new-text (layout-dir-list + new-result (cwd) width)) (new-model (make-browse-dir-list-res-obj 2 1 @@ -122,12 +112,10 @@ (begin (chdir wd) (chdir rest) - (let* ((new-result (evaluate "(directory-files)")) - (new-result-string (exp->string new-result)) + (let* ((new-result (directory-files)) (width (browse-dir-list-res-obj-width model)) - (new-text (layout-result-browse-dir-list - new-result-string new-result width - (cwd))) + (new-text (layout-dir-list + new-result (cwd) width)) (new-model (make-browse-dir-list-res-obj 2 1 @@ -145,35 +133,25 @@ new-model)) model))))))))) +(define (init-with-list-of-files files dir width) + (make-browse-dir-list-res-obj + 2 1 + files (layout-dir-list files dir width) dir + width (cwd) '() '() #f)) + (define browse-dir-list-receiver (lambda (message) + (debug-message "browse-dir-list-receiver " message) (cond + + ((init-with-result-message? message) + (let ((fs-objects (init-with-result-message-result message))) + (init-with-list-of-files + (map fs-object-name fs-objects) (cwd) + (init-with-result-message-width message)))) + ((next-command-message? message) - (let* ((command (next-command-string message)) - (parameters (next-command-message-parameters message)) - (width (next-command-message-width message))) - (if (< (length parameters) 2) - (let* ((result (list "forgot parameters?")) - (text - (layout-result-standard "forgot parameters?" - result width)) - (browse-obj - (make-browse-dir-list-res-obj 1 1 result text (cwd) - width (cwd) '() '() #f))) - browse-obj) - - (let* ((file-list - (evaluate (list-ref parameters 0))) - (dir (evaluate (list-ref parameters 1))) - (result-string (exp->string file-list)) - (width (next-command-message-width message)) - (text - (layout-result-browse-dir-list result-string - file-list width dir)) - (browse-obj - (make-browse-dir-list-res-obj 2 1 file-list text dir width - (cwd) '() '() #f))) - browse-obj)))) + (init-with-list-of-files (directory-files) (cwd))) ((print-message? message) (let* ((model (message-result-object message)) @@ -353,10 +331,10 @@ (marked-items (browse-dir-list-res-obj-res-marked-items model))) (string-append "'" (exp->string marked-items))))))) -(define browse-dir-list-rec (make-receiver "browse-dir-list" - browse-dir-list-receiver)) - -(set! receivers (cons browse-dir-list-rec receivers)) - - +(define (list-of-fs-objects? thing) + (and (proper-list? thing) + (every fs-object? thing))) +(register-plugin! (make-plugin "ls" + browse-dir-list-receiver + list-of-fs-objects?)) diff --git a/scheme/browse-list.scm b/scheme/browse-list.scm index 0ff5b00..f5c70cf 100644 --- a/scheme/browse-list.scm +++ b/scheme/browse-list.scm @@ -130,8 +130,7 @@ width '() '() #f))) browse-obj)) - (let ((lst - (evaluate (list-ref parameters 0)))) + (let ((lst (list-ref parameters 0))) (if (not (null? lst)) (let* ((result-string (map exp->string lst)) @@ -337,9 +336,4 @@ ))) - - -(define browse-list-rec (make-receiver "browse-list" - browse-list-receiver)) - -(set! receivers (cons browse-list-rec receivers)) \ No newline at end of file +(register-plugin! (make-plugin "browse-list" browse-list-receiver)) diff --git a/scheme/directory-files.scm b/scheme/directory-files.scm index 053bd58..837084b 100644 --- a/scheme/directory-files.scm +++ b/scheme/directory-files.scm @@ -61,15 +61,8 @@ (browse-dir-list-receiver browse-sel-message))) ))) - - -(define dir-files-rec1 - (make-receiver "directory-files" dir-files-receiver)) +(register-plugin! + (make-plugin "directory-files" dir-files-receiver)) -(set! receivers (cons dir-files-rec1 receivers)) - -(define dir-files-rec2 - (make-receiver "ls" dir-files-receiver)) - -(set! receivers (cons dir-files-rec2 receivers)) - +(register-plugin! + (make-plugin "ls" dir-files-receiver)) diff --git a/scheme/eval.scm b/scheme/eval.scm new file mode 100644 index 0000000..a5234d1 --- /dev/null +++ b/scheme/eval.scm @@ -0,0 +1,7 @@ +(define (directory-files . optional-args) + (let-optionals optional-args + ((dir (cwd)) + (dotfiles? #f)) + (map (lambda (file) + (make-fs-object file dir)) + (scsh-directory-files dir dotfiles?)))) diff --git a/scheme/fs-object.scm b/scheme/fs-object.scm new file mode 100644 index 0000000..ac95be9 --- /dev/null +++ b/scheme/fs-object.scm @@ -0,0 +1,9 @@ +(define-record-type fs-object :fs-object + (make-fs-object name path) + fs-object? + (name fs-object-name) + (path fs-object-path)) + +(define-record-discloser :fs-object + (lambda (r) + `(fs-object ,(fs-object-name r)))) diff --git a/scheme/layout.scm b/scheme/layout.scm new file mode 100644 index 0000000..efac7af --- /dev/null +++ b/scheme/layout.scm @@ -0,0 +1,63 @@ +;;seperate a long line into pieces, each fitting into a smaller line. +(define (seperate-line 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))))) + +;;the result is the "answer" of scsh +(define (layout-result-standard result-str result width) + (reverse (seperate-line result-str width))) + +;useful helpers +;;; EK: useful for what= +(define (get-marked-positions-1 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 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 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 exp) + (let ((exp-port (open-output-string))) + (write exp exp-port) + (get-output-string exp-port))) + +(define (sublist l pos k) + (let ((tmp (list-tail l pos))) + (reverse (list-tail (reverse tmp) + (- (length tmp) k))))) diff --git a/scheme/nuit-engine.scm b/scheme/nuit-engine.scm index 0d35b53..60f8777 100644 --- a/scheme/nuit-engine.scm +++ b/scheme/nuit-engine.scm @@ -42,20 +42,6 @@ (define result-window #f) (define result-frame-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")) - (define key-control-x 24) (define key-o 111) @@ -128,12 +114,12 @@ *current-history-item*) (define-record-type history-entry :history-entry - (make-history-entry command args result receiver) + (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!) - (receiver history-entry-receiver)) + (plugin history-entry-plugin)) (define (current-history-entry-selector-maker selector) (lambda () @@ -156,7 +142,7 @@ (cond ((current-history-item) => (lambda (entry) - (set-history-entry-result! (entry-data) new-value))) + (set-history-entry-result! (entry-data entry) new-value))) (else (values)))) (define (append-to-history! history-entry) @@ -187,125 +173,10 @@ ;;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-object - key prefix-key) - key-pressed-message? - (command-string key-pressed-command-string) - (result-object key-pressed-message-result-object) - (key key-pressed-message-key) - (prefix-key key-pressed-message-prefix-key)) - -;;print -(define-record-type print-message :print-message - (make-print-message command-string - result-object - width) - print-message? - (command-string print-message-command-string) - (result-object print-message-result-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) - print-object? - (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 - result-object) - restore-message? - (command-string restore-message-command-string) - (result-object restore-message-result-object)) - -;;request the selection -(define-record-type selection-message :selection-message - (make-selection-message command-string - result-object) - selection-message? - (command-string selection-message-command-string) - (result-object selection-message-result-object)) - -(define (message-result-object message) - ((cond - ((key-pressed-message? message) - key-pressed-message-result-object) - ((print-message? message) - print-message-result-object) - ((restore-message? message) - restore-message-result-object) - ((selection-message? message) - selection-message-result-object message) - (else - (error "This message-type has no field for result-objects" - message))) - message)) - -(define (message-command-string message) - ((cond - ((next-command-message? message) - next-command-string) - ((key-pressed-message? message) - key-pressed-command-string) - ((print-message? message) - print-message-command-string) - ((restore-message? message) - restore-message-command-string) - ((selection-message? message) - selection-message-command-string) - (else - (error "This message-type has no command field" message))) - message)) ;;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 - (really-make-receiver command rec type-predicate) - receiver? - (command receiver-command) - (rec receiver-rec) - (type-predicate receiver-type-predicate)) - -(define (make-receiver command rec . more) - (really-make-receiver command rec - (if (null? more) - (lambda (v) #f) - (car more)))) - -;;This list contains all the receivers that have been registered. -(define receivers '()) ;;************************************************************************* ;;Actions @@ -369,7 +240,7 @@ ch key-control-x))) (update-current-result! (post-message - (history-entry-receiver (entry-data (current-history-item))) + (history-entry-plugin (entry-data (current-history-item))) key-message)) (loop (wait-for-input) #f))) @@ -405,33 +276,47 @@ ((= ch 10) (let ((command (last (buffer-text command-buffer)))) - (call-with-values - (lambda () - (execute-command command)) - (lambda (result receiver) - (let ((new-entry - (make-history-entry command '() - result receiver))) - (append-to-history! new-entry) - (buffer-text-append-new-line! command-buffer) - (paint-result-window new-entry) - (paint-active-command-window) - (scroll-command-buffer) - (paint-command-window-contents) - (move-cursor command-buffer) - (refresh-result-window) - (refresh-command-window) - (loop (wait-for-input) c-x-pressed?)))))) + (if (not (string=? command "")) + (call-with-values + (lambda () + (execute-command command)) + (lambda (result plugin) + (let ((new-entry + (make-history-entry command '() + result plugin))) + (append-to-history! new-entry) + (buffer-text-append-new-line! command-buffer) + (paint-result-window new-entry) + (paint-active-command-window) + (scroll-command-buffer) + (paint-command-window-contents) + (move-cursor command-buffer) + (refresh-result-window) + (refresh-command-window) + (loop (wait-for-input) c-x-pressed?)))) + (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) - ;;(debug-message "loop after print-command-buffer " command-buffer) - (move-cursor command-buffer) - (refresh-command-window) - (loop (wait-for-input) c-x-pressed?))))) + (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! @@ -519,8 +404,7 @@ (wclear (app-window-curses-win result-window)) (paint-result-buffer (post-message - (or (history-entry-receiver entry) - (determine-receiver-by-command (history-entry-command entry))) + (history-entry-plugin entry) (make-print-message (history-entry-command entry) (history-entry-result entry) (buffer-num-cols command-buffer))))) @@ -551,64 +435,19 @@ (define (execute-command command) (let ((result (evaluate command))) (cond - ((determine-receiver-by-type result) - => (lambda (receiver) - (values result receiver))) + ((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-receiver + (post-message standard-plugin (make-next-command-message command '() (buffer-num-cols command-buffer))) - standard-receiver))))) - -'(define (execute-command) - (let* ((com (list-ref (buffer-text command-buffer) - (- (length (buffer-text command-buffer)) 1))) - (com-par (extract-com-and-par com)) - (command (car com-par)) - (parameters (cdr com-par)) - ;;todo: parameters - (message (make-next-command-message - command parameters result-cols)) - (model (post-message - (determine-receiver-by-command command) - message))) - (debug-message 'execute-command - com " " com-par ) - (if (not (= history-pos 0)) - (let ((hist-entry (make-history-entry (active-command) - (active-command-arguments) - (current-result))) - ;; hack of year - (active (make-history-entry command - (get-param-as-str parameters) - (if (standard-result-obj? model) - (standard-result-obj-result model) - model) - (and (standard-result-obj? model) - (determine-receiver-by-type - (standard-result-obj-result model)))))) - - (if (< history-pos (length history)) - (set! history (append history (list hist-entry))) - (set! history (append - (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) model) - (scroll-command-buffer))) + standard-plugin))))) ;;Extracts the name of the function and its parameters (define extract-com-and-par @@ -683,26 +522,26 @@ (read string-port))) (define evaluate - (let ((env (init-evaluation-environment 'nuit-eval-structure))) + (let ((env (init-evaluation-environment 'nuit-eval))) (lambda (exp) (with-fatal-error-handler (lambda (condition more) (cons 'error condition)) (eval (read-sexp-from-string exp) env))))) -(define (post-message receiver message) - ((receiver-rec receiver) message)) +(define (post-message plugin message) + ((plugin-fun plugin) message)) -(define (determine-receiver-by-command command) +(define (determine-plugin-by-command command) (or (find (lambda (r) - (string=? (receiver-command r) command)) - receivers) - standard-receiver)) + (string=? (plugin-command r) command)) + (plugin-list)) + standard-plugin)) -(define (determine-receiver-by-type result) +(define (determine-plugin-by-type result) (find (lambda (r) - ((receiver-type-predicate r) result)) - receivers)) + ((plugin-type-predicate r) result)) + (plugin-list))) ;;Management of the upper buffer ;;add a char to the buffer @@ -766,12 +605,11 @@ (define (post-print-message command result-object) (post-message - (determine-receiver-by-command command) + (determine-plugin-by-command command) (make-print-message command result-object (buffer-num-cols command-buffer)))) (define (paint-result-buffer print-object) - (debug-message "paint-result-buffer ") (let* ((window (app-window-curses-win result-window)) (text (print-object-text print-object)) (pos-y (print-object-pos-y print-object)) @@ -881,53 +719,6 @@ (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))))))))) - (define (sublist l pos k) (let ((tmp (list-tail l pos))) (reverse (list-tail (reverse tmp) @@ -948,39 +739,15 @@ (set! history '()) (set! history-pos 0) (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 message) - (cond - ((next-command-message? message) - (make-shortcut-result-obj #t)) - ((print-message? message) - (make-print-object 1 1 shortcuts '() '())) - ((key-pressed-message? message) - (message-result-object message)) - ((restore-message? message) - (values)) - ((selection-message? message) - ""))) +(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 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 @@ -1021,71 +788,6 @@ ((selection-message? message) ""))) -(define standard-receiver - (make-receiver #f standard-receiver-rec)) +(define standard-plugin + (make-plugin #f standard-receiver-rec)) -;;the result is the "answer" of scsh -(define (layout-result-standard result-str result width) - (reverse (seperate-line result-str width))) - -;useful helpers -(define (get-marked-positions-1 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 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 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 exp) - (let ((exp-port (open-output-string))) - (write exp exp-port) - (get-output-string exp-port))) - -;;seperate a long line into pieces, each fitting into a smaller line. -(define (seperate-line 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 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 ee80d97..f7277f0 100644 --- a/scheme/nuit-packages.scm +++ b/scheme/nuit-packages.scm @@ -13,18 +13,156 @@ history-last-entry)) (define-structure history history-interface - (open scheme + (open scheme define-record-types) (files history)) +;;; layout utilities + +(define-interface layout-interface + (export seperate-line + layout-result-standard + get-marked-positions-1 + get-marked-positions-2 + get-marked-positions-3 + exp->string + sublist)) + +(define-structure layout layout-interface + (open scheme + srfi-6 ;; basic string ports + ) + (files layout)) + +;;; process viewer plugin + +(define-structure process-view-plugin + (export) + (open scheme + srfi-1 + formats + pps + plugin + tty-debug) + (files process)) + +;;; file list view plugin + +(define-structure dirlist-view-plugin + (export) + (open scheme-with-scsh + define-record-types + layout + fs-object + srfi-1 + plugin + ncurses + tty-debug) + (files browse-directory-list)) + +;;; browse-list plugin + +(define-structure browse-list-plugin + (export) + (open scheme + define-record-types + ncurses + plugin + layout) + (files browse-list)) + +;;; fs-objects + +(define-interface fs-object-interface + (export make-fs-object + fs-object? + fs-object-name + fs-object-path)) + +(define-structure fs-object fs-object-interface + (open scheme + define-record-types) + (files fs-object)) + ;;; nuit evaluates the expressions entered into command buffer in this ;;; package -(define-structure nuit-eval-structure (export) - (open scheme-with-scsh - srfi-1 - pps) - (begin)) +(define-structure nuit-eval + (export) + (open + (modify scheme-with-scsh + (rename (directory-files scsh-directory-files))) + let-opt + srfi-1 + fs-object + pps) + (files eval)) + +;;; nuit plug-in registration + +(define-interface plugin-interface + (export make-plugin + plugin? + plugin-command + plugin-fun + plugin-type-predicate + register-plugin! + + make-print-object + print-object? + print-object-pos-y + print-object-pos-x + print-object-text + print-object-highlighted-lines + print-object-marked-lines + + next-command-message? + next-command-string + next-command-message-parameters + next-command-message-width + + init-with-result-message? + init-with-result-message-result + init-with-result-message-width + + key-pressed-message? + key-pressed-message-result-object + key-pressed-message-key + key-pressed-message-prefix-key + + print-message? + print-message-command-string + print-message-result-object + print-message-width + + restore-message? + restore-message-command-string + restore-message-result-object + + selection-message? + selection-message-command-string + selection-message-result-object + + message-result-object + message-command-string)) + +(define-interface plugin-host-interface + (export plugin-list + make-next-command-message + make-init-with-result-message + make-key-pressed-message + make-print-message + make-restore-message + make-selection-message)) + +(define-structures + ((plugin plugin-interface) + (plugin-host plugin-host-interface)) + (open scheme + define-record-types + let-opt + signals) + (files plugins)) ;;; nuit @@ -46,17 +184,16 @@ inspect-exception rt-modules tty-debug + fs-object + plugin + plugin-host + layout pps - history) + history + ;; the following modules are plugins + browse-list-plugin + dirlist-view-plugin + process-view-plugin) (files nuit-engine - handle-fatal-error - directory-files - find - cd - browse-directory-list - browse-list - process)) - - - + handle-fatal-error)) diff --git a/scheme/plugins.scm b/scheme/plugins.scm new file mode 100644 index 0000000..fef9b87 --- /dev/null +++ b/scheme/plugins.scm @@ -0,0 +1,125 @@ +(define *plugins* '()) + +(define (plugin-list) + *plugins*) + +(define-record-type plugin :plugin + (really-make-plugin command fun type-predicate) + plugin? + (command plugin-command) + (fun plugin-fun) + (type-predicate plugin-type-predicate)) + +(define-record-discloser :plugin + (lambda (r) + `(plugin ,(plugin-command r) ,(plugin-fun r)))) + +(define (make-plugin command fun . more) + (let-optionals more + ((type-predicate (lambda (v) #f))) + (really-make-plugin command fun type-predicate))) + +(define (register-plugin! plugin) + (set! *plugins* (cons plugin *plugins*))) + +;; answers + +(define-record-type print-object :print-object + (make-print-object pos-y + pos-x + text + highlighted-lines + marked-lines) + print-object? + (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)) + +;; messages + +(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)) + +(define-record-type init-with-result-message :init-with-result-message + (make-init-with-result-message result width) + init-with-result-message? + (result init-with-result-message-result) + (width init-with-result-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-object + key prefix-key) + key-pressed-message? + (command-string key-pressed-command-string) + (result-object key-pressed-message-result-object) + (key key-pressed-message-key) + (prefix-key key-pressed-message-prefix-key)) + +;;print +(define-record-type print-message :print-message + (make-print-message command-string + result-object + width) + print-message? + (command-string print-message-command-string) + (result-object print-message-result-object) + (width print-message-width)) + +;;restore (when side-effects occur) +(define-record-type restore-message :restore-message + (make-restore-message command-string + result-object) + restore-message? + (command-string restore-message-command-string) + (result-object restore-message-result-object)) + +;;request the selection +(define-record-type selection-message :selection-message + (make-selection-message command-string + result-object) + selection-message? + (command-string selection-message-command-string) + (result-object selection-message-result-object)) + +(define (message-result-object message) + ((cond + ((key-pressed-message? message) + key-pressed-message-result-object) + ((print-message? message) + print-message-result-object) + ((restore-message? message) + restore-message-result-object) + ((selection-message? message) + selection-message-result-object message) + (else + (error "This message-type has no field for result-objects" + message))) + message)) + +(define (message-command-string message) + ((cond + ((next-command-message? message) + next-command-string) + ((key-pressed-message? message) + key-pressed-command-string) + ((print-message? message) + print-message-command-string) + ((restore-message? message) + restore-message-command-string) + ((selection-message? message) + selection-message-command-string) + (else + (error "This message-type has no command field" message))) + message)) diff --git a/scheme/process.scm b/scheme/process.scm index eb09279..589d69f 100644 --- a/scheme/process.scm +++ b/scheme/process.scm @@ -22,6 +22,8 @@ (cond ((next-command-message? message) (pps)) + ((init-with-result-message? message) + (init-with-result-message-result message)) ((print-message? message) (let ((processes (message-result-object message))) (make-print-object 1 1 (print-processes processes) @@ -33,7 +35,5 @@ ((selection-message? message) "'()"))) -(set! receivers (cons (make-receiver "ps" pps-receiver - list-of-processes?) - receivers)) - +(register-plugin! + (make-plugin "ps" pps-receiver list-of-processes?))