added new files / removed a few (actually, that doesn't seem to work with the darcs2cvs-sync.scm)
This commit is contained in:
eknauel
parent
ada69eb0ce
commit
29ff444f3b
|
|
@ -1,262 +0,0 @@
|
|||
(define key-m 109)
|
||||
(define key-u 117)
|
||||
(define key-return 10)
|
||||
|
||||
(define (add-marks-to-special-file file-name fs-object)
|
||||
(let ((info (fs-object-info fs-object)))
|
||||
(cond
|
||||
((not info)
|
||||
(string-append " " file-name ": error during file-info!"))
|
||||
((file-info-directory? info)
|
||||
(string-append " " file-name "/"))
|
||||
((file-info-executable? info)
|
||||
(string-append "*" file-name))
|
||||
((file-info-symlink? info)
|
||||
(string-append "@" file-name))
|
||||
(else
|
||||
(string-append " " file-name)))))
|
||||
|
||||
(define (have-permission? mode perm-mask)
|
||||
(not (zero? (bitwise-and mode perm-mask))))
|
||||
|
||||
(define (format-permissions mode)
|
||||
(apply string-append
|
||||
(map (lambda (mask.symbol)
|
||||
(if (have-permission? mode (car mask.symbol))
|
||||
(cdr mask.symbol)
|
||||
"-"))
|
||||
'((#o0400 . "r") ;; owner read
|
||||
(#o0200 . "w") ;; owner write
|
||||
(#o0100 . "x") ;; owner exec
|
||||
(#o0040 . "r") ;; group read
|
||||
(#o0020 . "w") ;; group write
|
||||
(#o0010 . "x") ;; group exec
|
||||
(#o0004 . "r") ;; others read
|
||||
(#o0002 . "w") ;; others write
|
||||
(#o0001 . "x"))))) ;; others exec
|
||||
|
||||
(define (digits-left-of-comma-as-string float)
|
||||
(string-drop-right
|
||||
(number->string (truncate float)) 1))
|
||||
|
||||
(define (format-size/unit float unit)
|
||||
(string-append (digits-left-of-comma-as-string float) " " unit))
|
||||
|
||||
(define (format-size bytes)
|
||||
(let* ((kbyte 1024.0)
|
||||
(mbyte (* 1024 kbyte))
|
||||
(gbyte (* 1024 mbyte)))
|
||||
(cond
|
||||
((>= bytes gbyte)
|
||||
(format-size/unit (/ bytes gbyte) "GB"))
|
||||
((>= bytes mbyte)
|
||||
(format-size/unit (/ bytes mbyte) "MB"))
|
||||
((>= bytes kbyte)
|
||||
(format-size/unit (/ bytes kbyte) "KB"))
|
||||
(else
|
||||
(number->string bytes)))))
|
||||
|
||||
(define (format-user/group fi)
|
||||
(fill-up-string 17
|
||||
(string-append
|
||||
(cut-to-size 8 (->username (file-info:uid fi)))
|
||||
":"
|
||||
(cut-to-size 8 (group-info:name
|
||||
(group-info (file-info:gid fi)))))))
|
||||
|
||||
;; leave one line for the heading
|
||||
(define (calculate-number-of-lines result-buffer)
|
||||
(- (result-buffer-num-lines result-buffer)
|
||||
1))
|
||||
|
||||
(define (layout-fsobject parent-dir-len fsobject num-cols)
|
||||
(let ((file-name (combine-path (string-drop
|
||||
(fs-object-path fsobject)
|
||||
parent-dir-len)
|
||||
(fs-object-name fsobject)))
|
||||
(fi (fs-object-info fsobject)))
|
||||
(cut-to-size num-cols
|
||||
(string-append
|
||||
(fill-up-string
|
||||
30 (add-marks-to-special-file file-name fsobject))
|
||||
" "
|
||||
(fill-up-string
|
||||
7 (format-size (file-info:size fi)))
|
||||
" "
|
||||
(format-user/group fi)
|
||||
" "
|
||||
(format-permissions
|
||||
(file-info:mode fi))))))
|
||||
|
||||
(define (make-file-select-list fsobjects parent-dir num-lines num-cols)
|
||||
(let ((parent-dir-len (string-length parent-dir)))
|
||||
(make-select-list
|
||||
(cons (make-unmarked-element 'parent-dir #f " ..")
|
||||
(map (lambda (fs-object)
|
||||
(make-unmarked-element
|
||||
fs-object #t (layout-fsobject parent-dir-len
|
||||
fs-object num-cols)))
|
||||
fsobjects))
|
||||
num-lines)))
|
||||
|
||||
;;; lacks some coolness
|
||||
(define (abbrev-path path length)
|
||||
(if (< (string-length path) length)
|
||||
path
|
||||
(string-copy path
|
||||
(- (string-length path) length))))
|
||||
|
||||
(define header-line-path
|
||||
"Paths relative to ")
|
||||
|
||||
(define (make-header-line wdir width)
|
||||
(string-append
|
||||
header-line-path
|
||||
(if wdir
|
||||
(abbrev-path
|
||||
wdir (- width (string-length header-line-path)))
|
||||
"<unknown>")))
|
||||
|
||||
(define (paint-browser select-list wdir win buffer have-focus?)
|
||||
(wattron win (A-BOLD))
|
||||
(mvwaddstr win 0 0
|
||||
(make-header-line
|
||||
wdir (result-buffer-num-cols buffer)))
|
||||
(wattrset win (A-NORMAL))
|
||||
(paint-selection-list-at select-list 1 2 win
|
||||
buffer have-focus?))
|
||||
|
||||
(define (find-common-parent paths)
|
||||
(if (null? paths)
|
||||
""
|
||||
(let lp ((paths (cdr paths))
|
||||
(common (car paths))
|
||||
(common-len (string-length (car paths))))
|
||||
(if (null? paths)
|
||||
common
|
||||
(let ((prefix-len (string-prefix-length common (car paths))))
|
||||
(cond
|
||||
((= 0 prefix-len) (error "no prefix??" common (car paths)))
|
||||
((= 1 prefix-len) "/") ; search ends here
|
||||
((= prefix-len common-len) ; short cut
|
||||
(lp (cdr paths)
|
||||
common
|
||||
common-len))
|
||||
(else
|
||||
(lp (cdr paths)
|
||||
(substring common
|
||||
0
|
||||
prefix-len)
|
||||
prefix-len))))))))
|
||||
|
||||
(define (make-browser-for-dir dir buffer)
|
||||
(with-cwd dir
|
||||
(make-fsobjects-viewer (directory-files)
|
||||
buffer
|
||||
(cwd))))
|
||||
|
||||
(define (make-fsobjects-viewer fs-objects buffer . maybe-parent)
|
||||
(let-optionals maybe-parent
|
||||
((working-dir (find-common-parent
|
||||
(map fs-object-path fs-objects))))
|
||||
(let ((fs-objects fs-objects)
|
||||
(buffer buffer)
|
||||
(select-list
|
||||
(make-file-select-list
|
||||
fs-objects working-dir
|
||||
;; we need one line for the header
|
||||
(- (result-buffer-num-lines buffer) 1)
|
||||
(result-buffer-num-cols buffer))))
|
||||
|
||||
(define (handle-return-key self selected-entry num-lines)
|
||||
(cond
|
||||
((eq? selected-entry 'parent-dir)
|
||||
(let* ((maybe-parent (file-name-directory working-dir))
|
||||
(parent (if (string=? maybe-parent "") "/" maybe-parent)))
|
||||
(make-browser-for-dir parent buffer)))
|
||||
(else
|
||||
(let ((fi (fs-object-info selected-entry)))
|
||||
(if (and fi (file-info-directory? fi))
|
||||
(with-errno-handler
|
||||
((errno packet)
|
||||
(else
|
||||
(display packet)
|
||||
(newline)
|
||||
self))
|
||||
(make-browser-for-dir (fs-object-complete-path selected-entry)
|
||||
buffer))
|
||||
self)))))
|
||||
|
||||
(define (handle-key-press self key)
|
||||
(cond
|
||||
((= key key-return)
|
||||
(handle-return-key
|
||||
self (select-list-selected-entry select-list)
|
||||
(calculate-number-of-lines buffer)))
|
||||
(else
|
||||
(set! select-list
|
||||
(select-list-handle-key-press select-list key))
|
||||
self)))
|
||||
|
||||
(define (prepare-selection-for-scheme-mode file-names)
|
||||
(string-append "'" (write-to-string file-names)))
|
||||
|
||||
;; FIXME: quote file names containing space etc
|
||||
(define (prepare-selection-for-command-mode file-names)
|
||||
(string-join file-names))
|
||||
|
||||
(define (get-selection-as-text self for-scheme-mode? focus-object-table)
|
||||
(let* ((marked (select-list-get-marked select-list))
|
||||
(file-names
|
||||
(map fs-object-complete-path
|
||||
(if (null? marked)
|
||||
(list (select-list-selected-entry select-list))
|
||||
marked))))
|
||||
((if for-scheme-mode?
|
||||
prepare-selection-for-scheme-mode
|
||||
prepare-selection-for-command-mode)
|
||||
file-names)))
|
||||
|
||||
(define (get-selection-as-ref self focus-object-table)
|
||||
(let ((marked (select-list-get-marked select-list))
|
||||
(make-reference (lambda (obj)
|
||||
(make-focus-object-reference
|
||||
focus-object-table obj))))
|
||||
(if (null? marked)
|
||||
(write-to-string
|
||||
(make-reference (select-list-selected-entry select-list)))
|
||||
(string-append
|
||||
"(list "
|
||||
(string-join (map write-to-string (map make-reference marked)))
|
||||
")"))))
|
||||
|
||||
(lambda (message)
|
||||
(cond
|
||||
((eq? message 'paint)
|
||||
(lambda (self . args)
|
||||
(apply paint-browser
|
||||
(append (list select-list working-dir) args))))
|
||||
|
||||
((eq? message 'key-press)
|
||||
(lambda (self key control-x-pressed?)
|
||||
(handle-key-press self key)))
|
||||
|
||||
((eq? message 'get-selection-as-text)
|
||||
get-selection-as-text)
|
||||
|
||||
((eq? message 'get-selection-as-ref)
|
||||
get-selection-as-ref)
|
||||
|
||||
(else
|
||||
(error "fsobjects-viewer unknown message" message)))))))
|
||||
|
||||
(define (list-of-fs-objects? thing)
|
||||
(and (proper-list? thing)
|
||||
(every fs-object? thing)))
|
||||
|
||||
(register-plugin!
|
||||
(make-view-plugin make-fsobjects-viewer
|
||||
(lambda (thing)
|
||||
(or (fs-object? thing)
|
||||
(list-of-fs-objects? thing)))))
|
||||
|
||||
|
|
@ -1,339 +0,0 @@
|
|||
;;This addition provides the capability of displaying a list.
|
||||
;;There is only one list-item per line - if the item is too long for one
|
||||
;;single line it's symbolic representation is seperated into more
|
||||
;;than one lines.
|
||||
;;The user can scroll up and down in the list and he can select the items
|
||||
;;and later paste this newly-created list into the upper buffer.
|
||||
|
||||
|
||||
;;Result-Object-Data-Type
|
||||
(define-record-type browse-list-res-obj browse-list-res-obj
|
||||
(make-browse-list-res-obj pos-y
|
||||
pos-x
|
||||
line
|
||||
col-in-line
|
||||
list
|
||||
result-text
|
||||
width
|
||||
marked-items
|
||||
marked-pos
|
||||
c-x-pressed)
|
||||
browse-list-res-obj?
|
||||
(pos-y browse-list-res-obj-pos-y)
|
||||
(pos-x browse-list-res-obj-pos-x)
|
||||
(line browse-list-res-obj-line)
|
||||
(col-in-line browse-list-res-obj-col-in-line)
|
||||
(list browse-list-res-obj-file-list)
|
||||
(result-text browse-list-res-obj-result-text)
|
||||
(width browse-list-res-obj-width)
|
||||
(marked-items browse-list-res-obj-marked-items)
|
||||
(marked-pos browse-list-res-obj-marked-pos)
|
||||
(c-x-pressed browse-list-res-obj-c-x-pressed))
|
||||
|
||||
|
||||
;;The layout-function
|
||||
;;All lines are seperated
|
||||
(define layout-result-browse-list
|
||||
(lambda (lst width)
|
||||
(let loop ((pos-list 0)
|
||||
(buffer '()))
|
||||
(if (= pos-list (length lst))
|
||||
buffer
|
||||
(loop (+ pos-list 1)
|
||||
(append buffer
|
||||
(seperated-line (list-ref lst pos-list) width)))))))
|
||||
|
||||
;;seperate one line -> return a list of the single lines
|
||||
(define seperated-line
|
||||
(lambda (el width)
|
||||
(let loop ((old el)
|
||||
(new '()))
|
||||
(if (<= (string-length old) 0)
|
||||
new
|
||||
(if (>= (string-length old) width)
|
||||
(let* ((old-cut (substring old width (string-length old)))
|
||||
(new-app (string-append " " (substring old 0 width))))
|
||||
(loop old-cut (append new (list new-app))))
|
||||
(append new (list (string-append " " old))))))))
|
||||
|
||||
;;compute where the Cursor has to be put.
|
||||
;;The cursor is always located in the last line of one item of the list
|
||||
(define compute-pos-y
|
||||
(lambda (pos lst width)
|
||||
(let* ((before-pos (sublist lst 0 pos))
|
||||
(seperated-before (layout-result-browse-list before-pos width))
|
||||
(pos-before (length seperated-before)))
|
||||
pos-before)))
|
||||
|
||||
;;Find out which lines of the buffer are to highlight.
|
||||
;;Only those lines are highlighted, which contain the active item.
|
||||
(define get-highlighted-browse-list
|
||||
(lambda (line lst pos-y width)
|
||||
(let* ((act-line (list-ref lst (- line 1)))
|
||||
(seperated (seperated-line act-line width))
|
||||
(length-seperated (length seperated))
|
||||
(first-pos (- pos-y length-seperated)))
|
||||
(let loop ((count 1)
|
||||
(res '()))
|
||||
(if (> count length-seperated)
|
||||
res
|
||||
(loop (+ count 1)
|
||||
(append res (list (+ count first-pos)))))))))
|
||||
|
||||
;;find out which lines are to be marked. Lines are marked if they have
|
||||
;;recently been selected
|
||||
(define get-marked-pos-browse
|
||||
(lambda (marked lst width)
|
||||
(let loop ((m marked)
|
||||
(new '()))
|
||||
(if (null? m)
|
||||
new
|
||||
(let* ((pos (car m)))
|
||||
(loop (cdr m)
|
||||
(append (get-marked-browse-list pos lst width)
|
||||
new )))))))
|
||||
|
||||
(define get-marked-browse-list
|
||||
(lambda (pos lst width)
|
||||
(let* ((act-line (list-ref lst (- pos 1)))
|
||||
(seperated (seperated-line act-line width))
|
||||
(length-seperated (length seperated))
|
||||
(before-pos (sublist lst 0 pos))
|
||||
(seperated-before (layout-result-browse-list before-pos width))
|
||||
(length-before (- (length seperated-before) length-seperated)))
|
||||
(let loop ((res '())
|
||||
(count 1))
|
||||
(if (> count length-seperated)
|
||||
res
|
||||
(loop (cons (+ length-before count) res)
|
||||
(+ count 1)))))))
|
||||
|
||||
|
||||
;;Receiving-Function, that answers to incomming messages and changes state
|
||||
;;of the passed "browse-list-res-obj"
|
||||
(define browse-list-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)))
|
||||
(if (< (length parameters) 1)
|
||||
(begin
|
||||
(set! result (list "forgot parameter?"))
|
||||
(let* ((text
|
||||
(layout-result-standard "forgot parameters?"
|
||||
result width))
|
||||
(browse-obj
|
||||
(make-browse-list-res-obj 1 1 1 1 result text
|
||||
width '() '() #f)))
|
||||
browse-obj))
|
||||
|
||||
(let ((lst (list-ref parameters 0)))
|
||||
(if (not (null? lst))
|
||||
(let*
|
||||
((result-string (map exp->string lst))
|
||||
(text
|
||||
(layout-result-browse-list result-string
|
||||
(- width 1)))
|
||||
(sep-line-1 (seperated-line
|
||||
(exp->string (list-ref lst 0)) width))
|
||||
(pos-y (length sep-line-1))
|
||||
(browse-obj
|
||||
(make-browse-list-res-obj pos-y 1 1 1 lst text width
|
||||
'() '() #f)))
|
||||
browse-obj)
|
||||
(let
|
||||
((browse-obj
|
||||
(make-browse-list-res-obj 1 1 1 1 '("") '("") width
|
||||
'() '() #f)))
|
||||
browse-obj))))))
|
||||
|
||||
((print-message? message)
|
||||
(let* ((model (message-result-object message))
|
||||
(pos-y (browse-list-res-obj-pos-y model))
|
||||
(pos-x (browse-list-res-obj-pos-x model))
|
||||
(text (browse-list-res-obj-result-text model))
|
||||
(line (browse-list-res-obj-line model))
|
||||
(lst (map exp->string (browse-list-res-obj-file-list model)))
|
||||
(width (browse-list-res-obj-width model))
|
||||
(marked (browse-list-res-obj-marked-items model))
|
||||
(marked-pos (browse-list-res-obj-marked-pos model))
|
||||
(real-marked-pos (get-marked-pos-browse
|
||||
marked-pos
|
||||
lst
|
||||
width))
|
||||
(highlighted (get-highlighted-browse-list line lst pos-y width)))
|
||||
(make-print-object pos-y pos-x text highlighted real-marked-pos)))
|
||||
|
||||
((key-pressed-message? message)
|
||||
(let* ((model (message-result-object message))
|
||||
(key (key-pressed-message-key message))
|
||||
(c-x-pressed (browse-list-res-obj-c-x-pressed model)))
|
||||
|
||||
|
||||
(if c-x-pressed
|
||||
|
||||
(cond
|
||||
;;Ctrl+x s ->selection
|
||||
((= key 115)
|
||||
(let* ((marked-items (browse-list-res-obj-marked-items model))
|
||||
(actual-pos (browse-list-res-obj-line model))
|
||||
(all-items (browse-list-res-obj-file-list model)))
|
||||
(if (< actual-pos 1)
|
||||
model
|
||||
(let* ((actual-item (list-ref all-items (- actual-pos 1))))
|
||||
(begin
|
||||
(if (member actual-item marked-items)
|
||||
model
|
||||
(let*
|
||||
((new-marked-items (append marked-items
|
||||
(list actual-item)))
|
||||
(new-marked-pos (append
|
||||
(list actual-pos)
|
||||
(browse-list-res-obj-marked-pos
|
||||
model)))
|
||||
(new-model (make-browse-list-res-obj
|
||||
(browse-list-res-obj-pos-y model)
|
||||
(browse-list-res-obj-pos-x model)
|
||||
(browse-list-res-obj-line model)
|
||||
(browse-list-res-obj-col-in-line
|
||||
model)
|
||||
(browse-list-res-obj-file-list
|
||||
model)
|
||||
(browse-list-res-obj-result-text
|
||||
model)
|
||||
(browse-list-res-obj-width model)
|
||||
new-marked-items
|
||||
new-marked-pos
|
||||
#f)))
|
||||
new-model)))))))
|
||||
|
||||
|
||||
;;Ctrl+x u -> unselect
|
||||
((= key 117)
|
||||
(let* ((marked-items (browse-list-res-obj-marked-items model))
|
||||
(marked-pos (browse-list-res-obj-marked-pos model))
|
||||
(actual-pos (browse-list-res-obj-line model))
|
||||
(all-items (browse-list-res-obj-file-list model)))
|
||||
(if (< actual-pos 1)
|
||||
model
|
||||
(let* ((actual-item (list-ref all-items (- actual-pos 1)))
|
||||
(rest (member actual-item marked-items))
|
||||
(rest-pos (member actual-pos marked-pos)))
|
||||
(if (not rest)
|
||||
model
|
||||
(let* ((after-item (length rest))
|
||||
(after-marked (length rest-pos))
|
||||
(all-items (length marked-items))
|
||||
(all-marked (length marked-pos))
|
||||
(before-item (sublist marked-items
|
||||
0
|
||||
(- all-items
|
||||
after-item )))
|
||||
(before-marked (sublist marked-pos
|
||||
0
|
||||
(- all-marked
|
||||
after-marked)))
|
||||
(new-marked-items (append before-item
|
||||
(list-tail rest 1)))
|
||||
(new-marked-pos (append before-marked
|
||||
(list-tail rest-pos 1)))
|
||||
(new-model (make-browse-list-res-obj
|
||||
(browse-list-res-obj-pos-y model)
|
||||
(browse-list-res-obj-pos-x model)
|
||||
(browse-list-res-obj-line model)
|
||||
(browse-list-res-obj-col-in-line
|
||||
model)
|
||||
(browse-list-res-obj-file-list
|
||||
model)
|
||||
(browse-list-res-obj-result-text
|
||||
model)
|
||||
(browse-list-res-obj-width model)
|
||||
new-marked-items
|
||||
new-marked-pos
|
||||
#f)))
|
||||
new-model))))))
|
||||
|
||||
(else
|
||||
(make-browse-list-res-obj
|
||||
(browse-list-res-obj-pos-y model)
|
||||
(browse-list-res-obj-pos-x model)
|
||||
(browse-list-res-obj-line model)
|
||||
(browse-list-res-obj-col-in-line
|
||||
model)
|
||||
(browse-list-res-obj-file-list
|
||||
model)
|
||||
(browse-list-res-obj-result-text
|
||||
model)
|
||||
(browse-list-res-obj-width model)
|
||||
(browse-list-res-obj-marked-items model)
|
||||
(browse-list-res-obj-marked-pos model)
|
||||
#f)))
|
||||
|
||||
(cond
|
||||
|
||||
;;ctrl+x
|
||||
((= key 24)
|
||||
(make-browse-list-res-obj
|
||||
(browse-list-res-obj-pos-y model)
|
||||
(browse-list-res-obj-pos-x model)
|
||||
(browse-list-res-obj-line model)
|
||||
(browse-list-res-obj-col-in-line
|
||||
model)
|
||||
(browse-list-res-obj-file-list
|
||||
model)
|
||||
(browse-list-res-obj-result-text
|
||||
model)
|
||||
(browse-list-res-obj-width model)
|
||||
(browse-list-res-obj-marked-items model)
|
||||
(browse-list-res-obj-marked-pos model)
|
||||
#t))
|
||||
|
||||
|
||||
((= key key-up)
|
||||
(let ((line (browse-list-res-obj-line model))
|
||||
(lst (map exp->string (browse-list-res-obj-file-list model)))
|
||||
(width (browse-list-res-obj-width model)))
|
||||
(if (<= line 1)
|
||||
model
|
||||
(let* ((new-line (- line 1))
|
||||
(pos-y (compute-pos-y new-line lst width)))
|
||||
(make-browse-list-res-obj
|
||||
pos-y 1 new-line 1
|
||||
(browse-list-res-obj-file-list model)
|
||||
(browse-list-res-obj-result-text model)
|
||||
(browse-list-res-obj-width model)
|
||||
(browse-list-res-obj-marked-items model)
|
||||
(browse-list-res-obj-marked-pos model)
|
||||
#f)))))
|
||||
|
||||
((= key key-down)
|
||||
(let ((line (browse-list-res-obj-line model))
|
||||
(lst (map exp->string (browse-list-res-obj-file-list model)))
|
||||
(width (browse-list-res-obj-width model)))
|
||||
(if (>= line (length lst))
|
||||
model
|
||||
(let* ((new-line (+ line 1))
|
||||
(pos-y (compute-pos-y new-line lst width)))
|
||||
(make-browse-list-res-obj
|
||||
pos-y 1 new-line 1
|
||||
(browse-list-res-obj-file-list model)
|
||||
(browse-list-res-obj-result-text model)
|
||||
(browse-list-res-obj-width model)
|
||||
(browse-list-res-obj-marked-items model)
|
||||
(browse-list-res-obj-marked-pos model)
|
||||
#f)))))
|
||||
|
||||
(else model)))))
|
||||
|
||||
|
||||
((selection-message? message)
|
||||
(let* ((model (message-result-object message))
|
||||
(marked-items (browse-list-res-obj-marked-items model)))
|
||||
(string-append "'" (exp->string marked-items))))
|
||||
|
||||
)))
|
||||
|
||||
;(register-plugin! (make-plugin "browse-list" browse-list-receiver))
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
(define (init-evaluation-environment package)
|
||||
(let ((structure (reify-structure package)))
|
||||
(load-structure structure)
|
||||
(rt-structure->environment structure)))
|
||||
|
||||
(define *evaluation-environment*)
|
||||
|
||||
(define (set-evaluation-package! package-name)
|
||||
(set! *evaluation-environment*
|
||||
(init-evaluation-environment package-name)))
|
||||
|
||||
(define (evaluation-environment)
|
||||
*evaluation-environment*)
|
||||
|
||||
(define (read-sexp-from-string string)
|
||||
(let ((string-port (open-input-string string)))
|
||||
(read string-port)))
|
||||
|
||||
(define (eval-string str)
|
||||
(with-fatal-and-capturing-error-handler
|
||||
(lambda (condition raw-continuation continuation decline)
|
||||
raw-continuation)
|
||||
(lambda ()
|
||||
(eval (read-sexp-from-string str)
|
||||
(evaluation-environment)))))
|
||||
|
||||
(define (eval-s-expr s-expr)
|
||||
(with-fatal-and-capturing-error-handler
|
||||
(lambda (condition raw-continuation continuation decline)
|
||||
raw-continuation)
|
||||
(lambda ()
|
||||
(eval s-expr (evaluation-environment)))))
|
||||
|
||||
|
|
@ -1,93 +0,0 @@
|
|||
;;find
|
||||
;;This extension uses the unix-tool "find". You can only use this command in
|
||||
;;if "find" is present in your environment.
|
||||
;;This addition uses the capabilities defined in browse-directory-list
|
||||
|
||||
|
||||
|
||||
|
||||
(define-record-type find-res-obj find-res-obj
|
||||
(make-find-res-obj browse-obj)
|
||||
find-res-obj?
|
||||
(browse-obj find-res-obj-browse-obj))
|
||||
|
||||
|
||||
|
||||
(define find-receiver
|
||||
(lambda (message)
|
||||
(cond
|
||||
((next-command-message? message)
|
||||
(let* ((width (next-command-message-width message))
|
||||
(parameter (next-command-message-parameters message)))
|
||||
|
||||
(if (null? parameter)
|
||||
(let* ((result (list "Forgot parameters!"))
|
||||
(text
|
||||
(layout-result-standard "Forgot parameters!"
|
||||
result width))
|
||||
(browse-obj
|
||||
(make-browse-list-res-obj 1 1 1 1 result text
|
||||
width '() '() #f)))
|
||||
(make-find-res-obj browse-obj))
|
||||
|
||||
(let*
|
||||
((parameters (get-param-as-str parameter))
|
||||
(result (evaluate
|
||||
(string-append "(run/sexps (find" parameters "))")))
|
||||
(result-string (map exp->string result))
|
||||
(list-str (string-append "'" (exp->string result-string)))
|
||||
(browse-next-command-message
|
||||
(make-next-command-message "browse-list"
|
||||
(cons list-str
|
||||
(list "\"/\""))
|
||||
width)))
|
||||
|
||||
(make-find-res-obj (browse-list-receiver
|
||||
browse-next-command-message))))))
|
||||
((print-message? message)
|
||||
(let* ((model (message-result-object message))
|
||||
(width (print-message-width message))
|
||||
(browser (find-res-obj-browse-obj model))
|
||||
(browse-print-message
|
||||
(make-print-message "browse-list"
|
||||
browser
|
||||
width)))
|
||||
(browse-list-receiver browse-print-message)))
|
||||
((key-pressed-message? message)
|
||||
(let* ((model (message-result-object message))
|
||||
(key (key-pressed-message-key message))
|
||||
(browser (find-res-obj-browse-obj model))
|
||||
(browse-key-message
|
||||
(make-key-pressed-message "browse-list"
|
||||
browser
|
||||
key)))
|
||||
(make-find-res-obj (browse-list-receiver
|
||||
browse-key-message))))
|
||||
|
||||
((restore-message? message)
|
||||
(let* ((model (message-result-object message))
|
||||
(browser (find-res-obj-browse-obj model))
|
||||
(browse-restore-message
|
||||
(make-restore-message "browse-ist"
|
||||
browser)))
|
||||
(browse-list-receiver browse-restore-message)))
|
||||
((selection-message? message)
|
||||
(let* ((model (message-result-object message))
|
||||
(browser (find-res-obj-browse-obj model))
|
||||
(browse-sel-message
|
||||
(make-selection-message "browse-list"
|
||||
browser)))
|
||||
(browse-list-receiver browse-sel-message)))
|
||||
)))
|
||||
|
||||
|
||||
(define slash-away
|
||||
(lambda (path)
|
||||
(if (> (string-length path) 0)
|
||||
(substring path 1 (string-length path))
|
||||
path)))
|
||||
|
||||
|
||||
(define find-rec (make-receiver "find" find-receiver))
|
||||
|
||||
(set! receivers (cons find-rec receivers))
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
(define command-prefix #\,)
|
||||
|
||||
(define (split-scheme-command-line command-line)
|
||||
(let ((tokens (string-tokenize command-line)))
|
||||
(values (string->symbol (string-drop (car tokens) 1))
|
||||
(cdr tokens))))
|
||||
|
||||
(define (scheme-command-line? command-line)
|
||||
(char=? (string-ref (string-trim command-line) 0)
|
||||
command-prefix))
|
||||
|
||||
(define (eval-scheme-command command args)
|
||||
(case command
|
||||
((in)
|
||||
(set-evaluation-package! (string->symbol (car args)))
|
||||
(string-append "moved to package " (car args)))
|
||||
((open)
|
||||
(package-open!
|
||||
(evaluation-environment)
|
||||
(lambda ()
|
||||
(environment-ref
|
||||
(config-package) (string->symbol (car args)))))
|
||||
(string-append "opened package " (car args)))
|
||||
((user)
|
||||
(set-evaluation-package! 'nuit-eval)
|
||||
"moved to package nuit-eval")
|
||||
(else (error "unknwon scheme command"))))
|
||||
|
|
@ -0,0 +1,77 @@
|
|||
;(define-record-type element
|
||||
; (make-element markable? marked? value text)
|
||||
; element?
|
||||
; (markable? element-markable?)
|
||||
; (marked? element-marked?)
|
||||
; (value element-value)
|
||||
; (text element-text))
|
||||
|
||||
;(define-record-discloser :element
|
||||
; (lambda (r)
|
||||
; `(element ,(element-marked? r) ,(element-text r))))
|
||||
|
||||
;(define (make-unmarked-element value markable? text)
|
||||
; (make-element markable? #f value text))
|
||||
|
||||
;(define (make-marked-element value markable? text)
|
||||
; (make-element markable? #t value text))
|
||||
|
||||
(define (element-value x) x)
|
||||
(define (element-text x) x)
|
||||
|
||||
(define-record-type select-line :select-line
|
||||
(really-make-select-line elements cursor-index num-cols)
|
||||
select-line?
|
||||
(elements select-line-elements)
|
||||
(cursor-index select-line-cursor-index set-select-line-cursor-index!)
|
||||
(num-cols select-line-num-cols))
|
||||
|
||||
(define (make-select-line elements)
|
||||
(really-make-select-line elements 0 (length elements)))
|
||||
|
||||
(define (select-line-handle-key-press! select-line key)
|
||||
(cond
|
||||
((= key key-right)
|
||||
(move-cursor-right! select-line))
|
||||
((= key key-left)
|
||||
(move-cursor-left! select-line))
|
||||
(else #f)))
|
||||
|
||||
(define (move-cursor-left! select-line)
|
||||
(let ((old-col (select-line-cursor-index select-line)))
|
||||
(if (and (> old-col 0)
|
||||
(> (select-line-num-cols select-line) 1))
|
||||
(set-select-line-cursor-index! select-line (- old-col 1)))))
|
||||
|
||||
(define (move-cursor-right! select-line)
|
||||
(let ((old-col (select-line-cursor-index select-line)))
|
||||
(if (< old-col (- (select-line-num-cols select-line) 1))
|
||||
(set-select-line-cursor-index! select-line (+ old-col 1)))))
|
||||
|
||||
(define (paint-select-line select-line win result-buffer have-focus?)
|
||||
(paint-select-line-at select-line 0 0 win result-buffer have-focus?))
|
||||
|
||||
(define (paint-select-line-at select-line x y win result-buffer have-focus?)
|
||||
(let ((cursor-col (select-line-cursor-index select-line)))
|
||||
(let lp ((elts (select-line-elements select-line))
|
||||
(i 0)
|
||||
(x x))
|
||||
(cond ((null? elts)
|
||||
(values))
|
||||
((= i cursor-col)
|
||||
(let ((text (element-text (car elts))))
|
||||
(wattron win (A-REVERSE))
|
||||
(mvwaddstr win y x text)
|
||||
(wattrset win (A-NORMAL))
|
||||
(lp (cdr elts) (+ i 1) (+ x (string-length text)))))
|
||||
(else
|
||||
(let ((text (element-text (car elts))))
|
||||
(mvwaddstr win y x text)
|
||||
(lp (cdr elts) (+ i 1) (+ x (string-length text)))))))))
|
||||
|
||||
(define (select-line-selected-entry select-line)
|
||||
(element-value
|
||||
(list-ref (select-line-elements select-line)
|
||||
(select-line-cursor-index select-line))))
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
(define (display-to-string val)
|
||||
(let ((exp-port (open-output-string)))
|
||||
(display exp exp-port)
|
||||
(get-output-string exp-port)))
|
||||
|
||||
;;expression as string
|
||||
(define (write-to-string exp)
|
||||
(let ((exp-port (open-output-string)))
|
||||
(write exp exp-port)
|
||||
(get-output-string exp-port)))
|
||||
|
||||
(define (on/off-option-processor name)
|
||||
(lambda (option arg-name arg ops)
|
||||
(cons (cons name #t) ops)))
|
||||
|
||||
Loading…
Reference in New Issue