[mcclim-devel] file-browser example application

[Robert Goldman]

Andy Hefner wrote:
> On 1/5/07, Robert Goldman <rpgoldman at real-time.com> wrote:
 [...snip...]

>> BTW, I think a more elegant solution might be made that would use
>> satisfies to define the dir-pathname presentation-type more
>> declaratively.  But I couldn't figure out how to do it...
> 
> Good idea. '(and pathname (satisfies my-directory-p)) doesn't do it?
> 

I made a stab at it, but no, it didn't seem to work.  I am attaching two
different versions of the file-browser:  one that works, using a new
presentation-type, dir-pathname, and one that tries to do the job with
(and pathname (satisfies cl-fad:directory-pathname-p)), that doesn't work.

Probably there's some simple idiocy I've committed that makes this not
work, either a bug, or a misunderstanding of presentation types and the
relationship between presentation and the presented object.  If anyone
can correct this, I will appreciate it, and will see to it that the
answer, duly credited, appears in the Guided-Tour paper, to enlighten
future seekers after CLIMmy wisdom.

Best,
R
-------------- next part --------------
(eval-when (:compile-toplevel)
  (asdf:oos 'asdf:load-op :clim)
  (asdf:oos 'asdf:load-op :clim-clx))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (asdf:oos 'asdf:load-op :cl-fad))

(in-package :clim-user)

; LTAG-start:file-browser-all
(define-application-frame file-browser ()
  ((active-files :initform nil :accessor active-files))
  (:panes
   (file-browser :application
		 :display-function '(dirlist-display-files)
		 ;; Call the display-function whenever the command
		 ;; loop makes a ``full-cycle''
		 :display-time :command-loop)
   (interactor :interactor))
  (:layouts (default (vertically ()
				 file-browser
				 interactor))))

;;;(define-presentation-type dir-pathname ()
;;;  :inherit-from 'pathname)

(defmethod dirlist-display-files ((frame file-browser) pane)
  ;; Clear old displayed entries
  (clear-output-record (stream-output-history pane))

  (dolist (file (active-files frame))
    ;; Instead of write-string, we use present so that the link to
    ;; object file and the semantic information that file is
    ;; pathname is retained.
    (present file 'pathname
;;	     (if (cl-fad:directory-pathname-p file) 'dir-pathname 'pathname)
	     :stream pane)
    (terpri pane)))

(define-file-browser-command (com-edit-directory :name "Edit Directory")
  ((dir '(and pathname (satisfies cl-fad:directory-pathname-p))))
  ;; the following was a previous attempt to deal with the oddities of
  ;; CL pathnames.  Unfortunately, it does not work properly with all
  ;; lisp implementations.  Because of these oddities, we really need
  ;; a layer like cl-fad to keep things straight. [2007/01/05:rpg]
;;;  (let ((dir (make-pathname :directory (pathname-directory dir)
;;;			    :name :wild :type :wild :version :wild
;;;			    :defaults dir)))
    (setf (active-files *application-frame*)
	  (cl-fad:list-directory dir)))

(define-presentation-to-command-translator pathname-to-edit-command
    ((and pathname (satisfies cl-fad:directory-pathname-p)) ; source presentation-type
     com-edit-directory                 ; target-command
     file-browser                       ; command-table
     :gesture :select                   ; use this translator for pointer clicks
     :documentation "Edit this path")   ; used in context menu
    (object)                            ; argument List
    (list object))                        ; arguments for target-command

(define-file-browser-command (com-quit :name t) ()
  (frame-exit *application-frame*)
  )

(defmethod adopt-frame :after (frame-manager (frame file-browser))
  (declare (ignore frame-manager))
  (execute-frame-command frame
	`(com-edit-directory ,(make-pathname :directory '(:absolute)))))

; LTAG-end
-------------- next part --------------
(eval-when (:compile-toplevel)
  (asdf:oos 'asdf:load-op :clim)
  (asdf:oos 'asdf:load-op :clim-clx))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (asdf:oos 'asdf:load-op :cl-fad))

(in-package :clim-user)

; LTAG-start:file-browser-all
(define-application-frame file-browser ()
  ((active-files :initform nil :accessor active-files))
  (:panes
   (file-browser :application
		 :display-function '(dirlist-display-files)
		 ;; Call the display-function whenever the command
		 ;; loop makes a ``full-cycle''
		 :display-time :command-loop)
   (interactor :interactor))
  (:layouts (default (vertically ()
				 file-browser
				 interactor))))

(define-presentation-type dir-pathname ()
  :inherit-from 'pathname)

(defmethod dirlist-display-files ((frame file-browser) pane)
  ;; Clear old displayed entries
  (clear-output-record (stream-output-history pane))

  (dolist (file (active-files frame))
    ;; Instead of write-string, we use present so that the link to
    ;; object file and the semantic information that file is
    ;; pathname is retained.
    (present file 
	     (if (cl-fad:directory-pathname-p file) 'dir-pathname 'pathname)
	     :stream pane)
    (terpri pane)))

(define-file-browser-command (com-edit-directory :name "Edit Directory")
  ((dir 'dir-pathname))
  ;; the following was a previous attempt to deal with the oddities of
  ;; CL pathnames.  Unfortunately, it does not work properly with all
  ;; lisp implementations.  Because of these oddities, we really need
  ;; a layer like cl-fad to keep things straight. [2007/01/05:rpg]
;;;  (let ((dir (make-pathname :directory (pathname-directory dir)
;;;			    :name :wild :type :wild :version :wild
;;;			    :defaults dir)))
    (setf (active-files *application-frame*)
	  (cl-fad:list-directory dir)))

(define-presentation-to-command-translator pathname-to-edit-command
    (dir-pathname                       ; source presentation-type
     com-edit-directory                 ; target-command
     file-browser                       ; command-table
     :gesture :select                   ; use this translator for pointer clicks
     :documentation "Edit this path")   ; used in context menu
    (object)                            ; argument List
    (list object))                        ; arguments for target-command

(define-file-browser-command (com-quit :name t) ()
  (frame-exit *application-frame*)
  )

(defmethod adopt-frame :after (frame-manager (frame file-browser))
  (declare (ignore frame-manager))
  (execute-frame-command frame
	`(com-edit-directory ,(make-pathname :directory '(:absolute)))))

; LTAG-end