[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
toy browser
- To: info-macl
- Subject: toy browser
- From: alms@cambridge.apple.com (Andrew L. M. Shalit)
- Date: Thu, 3 May 90 17:50:54 -0400
Enclosed in this message is a toy browser written for MACL 1.3.x.
This was written in two hours (one hour to prototype, and one hour
to refine---done on a wager with a Pascal hacker :-). It's actually
kind of cute, and may be functional.
I'm enclosing it, cause it's pretty short, and I don't have much experience
with FTP.
Enjoy.
-andrew
alms@cambridge.apple.com
----------cut here--------------
(setq *save-definitions* t)
(defun find-subclasses (&optional (root (ask nil (self))))
(cons root
(mapcan #'find-subclasses
(ask root (objvar object-children)))))
(defobfun (search-for-def *fred-window*) (class &optional method)
(let* ((search-string (coerce (if method
(format nil "(defobfun (~a ~a)" method class)
(format nil "(defobject ~a" class))
'simple-string))
(buffer (window-buffer))
(pos (buffer-string-pos buffer search-string)))
(when pos
(set-mark (window-cursor-mark)
(buffer-line-start buffer pos))
(set-mark (window-start-mark)
(buffer-line-start buffer pos (- *next-screen-context-lines*))))
(window-update)))
(defun make-browser (&optional (root (ask nil (self))))
(oneof *dialog*
:window-title (format nil "browser for ~a"
(ask root (objvar object-name)))
:window-type :document
:window-position #@(205 79)
:window-size #@(575 447)
:window-font '("geneva" 9 :srccopy :plain)
:dialog-items
(list (make-dialog-item *static-text-dialog-item*
#@(145 189) #@(380 61) ""
nil
:dialog-item-nick-name 'documentation)
(make-dialog-item *static-text-dialog-item*
#@(144 170) #@(421 16) ""
nil
:dialog-item-nick-name 'arglist)
(make-dialog-item *static-text-dialog-item*
#@(144 154) #@(417 16) ""
nil
:dialog-item-nick-name 'source-file)
(make-dialog-item *static-text-dialog-item*
#@(6 187) #@(110 16) "Documentation:"
nil
:dialog-item-font '("chicago" 12))
(make-dialog-item *static-text-dialog-item*
#@(6 170) #@(101 16) "Argument List:"
nil
:dialog-item-font '("chicago" 12))
(make-dialog-item *static-text-dialog-item*
#@(6 152) #@(84 16) "Source File:"
nil
:dialog-item-font '("chicago" 12))
(make-dialog-item *button-dialog-item*
#@(411 420) #@(120 16) "Get Source File"
#'(lambda ()
(let* ((class (ask (ask-named-item 'class-table
(let* ((cell (car (selected-cells))))
(when cell (cell-contents cell))))
(objvar object-name)))
(method (ask-named-item 'method-table
(let* ((cell (car (selected-cells))))
(when cell (cell-contents cell)))))
(source-file
(car (if method
(ccl::get-source-files method 'function class)
(ccl::get-source-files class 'variable)))))
(ask (ccl::find-or-fred source-file t)
(search-for-def class method))))
:dialog-item-font '("chicago" 12)
:default-button nil
:dialog-item-nick-name 'source-button)
(make-dialog-item *static-text-dialog-item*
#@(4 259) #@(562 145) ""
nil
:dialog-item-nick-name 'source-text
:allow-returns t)
#|(make-dialog-item *static-text-dialog-item*
#@(6 237) #@(90 16) "Source Code:" nil
:dialog-item-font '("Chicago" 12 :srccopy :plain)) |#
;variable-table
(make-dialog-item *sequence-dialog-item*
#@(384 0) #@(191 143) ""
nil
:dialog-item-nick-name 'variable-table
:cell-size #@(180 14)
:table-hscrollp nil
:table-vscrollp t
:table-sequence '())
;method-table
(make-dialog-item *sequence-dialog-item*
#@(192 0) #@(191 143) ""
#'(lambda ()
(if (double-click-p)
(ask-named-item 'source-button
(dialog-item-action))
(let* ((*print-pretty* t)
(class (ask-named-item 'class-table
(cell-contents (car (selected-cells)))))
(class-name (ask class (objvar object-name)))
(method (cell-contents (car (selected-cells))))
(source-form (ask class
(uncompile-function
(symbol-function method))))
(source-string (if source-form
(prin1-to-string source-form)
";source not available"))
(arglist-string (let* ((my-stream
(make-string-output-stream)))
(arglist-to-stream method my-stream)
(get-output-stream-string my-stream)))
(doc-string (documentation method 'function)))
(ask-named-item 'source-text
(set-dialog-item-text source-string))
(let* ((pathname (car (ccl::get-source-files method
'function
class-name))))
(ask-named-item 'source-file
(set-dialog-item-text (if pathname
(prin1-to-string
(namestring pathname))
"source file not recorded"))))
(ask-named-item 'arglist
(set-dialog-item-text arglist-string))
(ask-named-item 'documentation
(set-dialog-item-text (or doc-string
"no documentation string"))))))
:dialog-item-nick-name 'method-table
:cell-size #@(180 14)
:table-hscrollp nil
:table-vscrollp t
:table-sequence '())
;class-table
(make-dialog-item *sequence-dialog-item*
#@(0 0) #@(191 143) ""
#'(lambda ()
(if (double-click-p)
(ask-named-item 'source-button
(dialog-item-action))
(progn
(ask-named-item 'method-table
(mapcar #'cell-deselect (selected-cells)))
(let* ((class (car (selected-cells)))
(funcs nil)
(vars nil)
(class-name nil))
(when class
(setq class (cell-contents class))
(setq class-name (ask class (objvar object-name)))
(do-object-functions (one-func class)
(push one-func funcs))
(do-object-variables (one-var class)
(push one-var vars)))
(ask-named-item 'method-table
(set-table-sequence (sort funcs #'string<)))
(ask-named-item 'variable-table
(set-table-sequence (sort vars #'string<)))
(let* ((pathname (car (ccl::get-source-files class-name
'variable))))
(ask-named-item 'source-file
(set-dialog-item-text (if pathname
(prin1-to-string
(namestring pathname))
"source file not recorded"))))
(ask-named-item 'arglist
(set-dialog-item-text ""))
(ask-named-item 'documentation
(set-dialog-item-text (or (documentation class-name 'variable)
"no documentation string")))))))
:dialog-item-nick-name 'class-table
:cell-size #@(180 14)
:table-hscrollp nil
:table-vscrollp t
:table-sequence (sort (delete-duplicates
(find-subclasses root))
#'string<
:key #'(lambda (object)
(ask object (objvar object-name))))
:table-print-function #'(lambda (object stream)
(format stream "~a"
(ask object
(objvar object-name))))))))
;(make-browser)