A hacked beyond recognition patch: Move plugins to seperate modules,
put plugin api and registration into a module, add a new message-type, make directory-files plugin work again, delete some hundred lines of extremly silly code,
This commit is contained in:
eknauel
parent
87f701f59d
commit
428c9587cc
|
|
@ -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?))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(register-plugin! (make-plugin "browse-list" browse-list-receiver))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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?))))
|
||||
|
|
@ -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))))
|
||||
|
|
@ -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)))))
|
||||
|
|
@ -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))))))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
@ -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?))
|
||||
|
|
|
|||
Loading…
Reference in New Issue