From 6e72d5abd4215819335f095611c8872ce2ecfca2 Mon Sep 17 00:00:00 2001 From: eknauel Date: Tue, 31 May 2005 08:01:06 +0000 Subject: [PATCH] Use object-oriented approach --- scheme/browse-directory-list.scm | 171 +++++++++++++++++-------------- scheme/nuit-packages.scm | 2 +- 2 files changed, 94 insertions(+), 79 deletions(-) diff --git a/scheme/browse-directory-list.scm b/scheme/browse-directory-list.scm index a931d39..6e8e4b6 100644 --- a/scheme/browse-directory-list.scm +++ b/scheme/browse-directory-list.scm @@ -2,18 +2,6 @@ (define key-u 117) (define key-return 10) -(define-record-type filelist-state :filelist-state - (make-filelist-state files select-list working-dir) - filelist-state? - (files filelist-state-files) - (select-list filelist-state-select-list) - (working-dir filelist-state-working-dir)) - -(define-record-discloser :filelist-state - (lambda (r) - `(filelist-state ,(filelist-state-working-dir r) - ,(filelist-state-files r)))) - (define (add-marks-to-special-file file-name fs-object) (let ((info (fs-object-info fs-object))) (cond @@ -60,39 +48,27 @@ (define header-line-path "Paths relative to ") -(define (make-header-line state width) - (let ((dir (filelist-state-working-dir state))) - (string-append - header-line-path - (if dir - (abbrev-path - dir (- width (string-length header-line-path))) - "")))) +(define (make-header-line wdir width) + (string-append + header-line-path + (if wdir + (abbrev-path + wdir (- width (string-length header-line-path))) + ""))) -(define (paint-browser state) - (lambda (win result-buffer have-focus?) - (wattron win (A-BOLD)) - (mvwaddstr win 0 0 - (make-header-line - state (result-buffer-num-cols result-buffer))) - (wattrset win (A-NORMAL)) - ((paint-selection-list-at - (filelist-state-select-list state) 1 2) - win result-buffer have-focus?))) +(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 (make-browser-for-dir dir num-lines) - (with-cwd dir - (let ((fs-objects (directory-files))) - (make-filelist-state - fs-objects (make-file-select-list fs-objects (cwd) num-lines) - (cwd))))) - -(define (make-browser-for-fs-objects fs-objects num-lines) - (let ((parent-dir (find-common-parent (map fs-object-path fs-objects)))) - (make-filelist-state - fs-objects - (make-file-select-list fs-objects parent-dir num-lines) - parent-dir))) +(define (make-browser-for-dir instance dir) + (let ((new-instance (make-fsobjects-viewer))) + (send new-instance 'init-browser-for-dir + dir (send instance 'get-buffer)))) (define (find-common-parent paths) (if (null? paths) @@ -117,13 +93,13 @@ prefix-len) prefix-len)))))))) -(define (handle-return-key state selected-entry num-lines) +(define (handle-return-key instance selected-entry num-lines) (cond ((eq? selected-entry 'parent-dir) (let* ((maybe-parent - (file-name-directory (filelist-state-working-dir state))) + (file-name-directory (send instance 'get-working-dir))) (parent (if (string=? maybe-parent "") "/" maybe-parent))) - (make-browser-for-dir parent num-lines))) + (make-browser-for-dir instance parent))) (else (let ((fi (fs-object-info selected-entry))) (if (and fi (file-info-directory? fi)) @@ -132,50 +108,89 @@ (else (display packet) (newline) - state)) - (make-browser-for-dir (fs-object-complete-path selected-entry) - num-lines)) - state))))) + instance)) + (make-browser-for-dir instance + (fs-object-complete-path selected-entry))) + instance))))) -(define (handle-key-press message) - (let* ((state (message-result-object message)) - (select-list (filelist-state-select-list state)) - (key (key-pressed-message-key message))) +(define (handle-key-press instance key) + (let ((select-list (send instance 'get-select-list)) + (buffer (send instance 'get-buffer))) (cond ((= key key-return) (handle-return-key - state (select-list-selected-entry select-list) - (calculate-number-of-lines - (key-pressed-message-result-buffer message)))) + instance (select-list-selected-entry select-list) + (calculate-number-of-lines buffer))) (else - (make-filelist-state - (filelist-state-files state) - (select-list-handle-key-press - (filelist-state-select-list state) message) - (filelist-state-working-dir state)))))) + (send instance 'set-select-list! + (select-list-handle-key-press select-list key)) + instance)))) -(define (filelist-browser message) - (cond +(define (make-fsobjects-viewer) + (let ((fs-objects #f) + (buffer #f) + (select-list #f) + (working-dir #f)) + (lambda (message) + (cond - ((init-with-result-message? message) - (let ((fsobjects (init-with-result-message-result message)) - (num-lines (calculate-number-of-lines - (init-with-result-message-buffer message)))) - (make-browser-for-fs-objects fsobjects num-lines))) - - ((print-message? message) - (paint-browser (message-result-object message))) + ((eq? message 'init) + (lambda (self new-fs-objects new-buffer) + (let ((num-lines (result-buffer-num-lines new-buffer)) + (parent-dir + (find-common-parent + (map fs-object-path new-fs-objects)))) + (set! buffer new-buffer) + (set! fs-objects new-fs-objects) + (set! working-dir parent-dir) + (set! select-list + (make-file-select-list fs-objects parent-dir num-lines)) + self))) - ((key-pressed-message? message) - (handle-key-press message)) - - (else - (values)))) + ((eq? message 'init-browser-for-dir) + (lambda (self new-dir new-buffer) + (with-cwd new-dir + (let ((new-fs-objects (directory-files))) + (set! buffer new-buffer) + (set! fs-objects new-fs-objects) + (set! working-dir new-dir) + (set! select-list + (make-file-select-list + fs-objects (cwd) (result-buffer-num-lines new-buffer))) + self)))) + + ((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-select-list) + (lambda (self) + select-list)) + + ((eq? message 'set-select-list!) + (lambda (self new-select-list) + (set! select-list new-select-list))) + + ((eq? message 'get-buffer) + (lambda (self) + buffer)) + + ((eq? message 'get-working-dir) + (lambda (self) + working-dir)) + + (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 filelist-browser + (make-view-plugin make-fsobjects-viewer list-of-fs-objects?)) diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm index 4db8b40..b5f49c3 100644 --- a/scheme/nuit-packages.scm +++ b/scheme/nuit-packages.scm @@ -90,11 +90,11 @@ (define-structure dirlist-view-plugin (export) (open (modify nuit-eval (hide string-copy)) - define-record-types srfi-1 (subset srfi-13 (string-copy string-drop string-prefix-length)) signals + objects layout fs-object select-list