[rjain-utils-cvs] CVS formulate/src/clim-ui

Update of /project/rjain-utils/cvsroot/formulate/src/clim-ui In directory cl-net:/tmp/cvs-serv31147/src/clim-ui

Modified Files: application.lisp formulate.clim-ui.asd objects.lisp variables.lisp Added Files: classes.lisp Log Message: usability enhancements

separate class definer into a separate application frame and make it work

--- /project/rjain-utils/cvsroot/formulate/src/clim-ui/application.lisp 2009/11/24 10:06:47 1.2 +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/application.lisp 2009/12/25 21:03:22 1.3 @@ -1,11 +1,18 @@ (in-package :formulate.clim-ui)

+(defvar *document-package-counter* 0) + +(defun make-document-package () + (make-package (format nil "Document ~A" (incf *document-package-counter*)) + :use '(common-lisp formulate)))

(define-application-frame formulate () - ((monitored-values :initform (make-array 5 :fill-pointer 0 :adjustable t) + ((document-package :initform (make-document-package) :initarg :document-package :accessor document-package) + (monitored-values :initform (make-array 5 :fill-pointer 0 :adjustable t) :accessor monitored-values)) (:panes (interactor :interactor - :scroll-bars t) + :scroll-bars t + :min-width 400) (monitor :application :scroll-bars t :incremental-redisplay t @@ -16,8 +23,26 @@ monitor interactor)))

+(defmethod shared-initialize :after ((formulate formulate) slots &key) + (setf (frame-pretty-name formulate) + (format nil "Formulate: ~A" (package-name (document-package formulate))))) + +(defmethod default-frame-top-level ((frame formulate) &key &allow-other-keys) + (let ((*package* (document-package frame)) + (*debugger-hook* (if (find-package :clim-debugger) + (find-symbol "DEBUGGER" :clim-debugger) + *debugger-hook*))) + (call-next-method))) + +(define-formulate-command com-import-library ((name 'string)) + (use-package (string-upcase name))) + +;;;; +;;;; DATA MONITOR +;;;; + (defun display-monitor (*application-frame* *standard-output*) - (updating-output (t :unique-id (monitored-values *application-frame*)) + (updating-output (t) (map nil (lambda (item) (display-monitored-value item)) (monitored-values *application-frame*))))

@@ -28,31 +53,25 @@ (defun remove-from-monitor (value *application-frame*) (delete value (monitored-values *application-frame*)))

-(defvar *error-formulator* nil) - (defmacro display-formula-value (location) `(catch 'formula-value-fail (handler-bind ((error #'(lambda (error) (display-formula-error error formulate::*formulating*) (throw 'formula-value-fail nil)))) - (let ((error-source-p (eql *error-formulator* - (let ((formulate::*get-formulator* t)) - ,location))) - (value ,location)) - (when error-source-p - (with-text-face (t :bold) - (with-drawing-options (t :ink +red+) - (write-string ">>>")))) - (present value (presentation-type-of value)) - (when error-source-p - (with-text-face (t :bold) - (with-drawing-options (t :ink +red+) - (write-string "<<<")))))))) + (let* ((value ,location) + (ptype (if (typep (class-of value) 'formulated-class) + 'formulated-object + (presentation-type-of value)))) + (present value ptype)))))

(defmethod frame-standard-output ((frame formulate)) (get-frame-pane frame 'interactor))

+;;;; +;;;; FORMULA ERROR HANDLING +;;;; + (define-presentation-type formula-error () :inherit-from t)

@@ -65,17 +84,26 @@ (print-unreadable-object ((formula-error-error error) stream :type t)))

(defun display-formula-error (error formulator) - (with-output-as-presentation (t - (make-formula-error :error error :formulator formulator) - 'formula-error) + (with-output-as-presentation (t (make-formula-error :error error :formulator formulator) + 'formula-error) (with-text-face (t :italic) (with-drawing-options (t :ink +red+) - (write-char #!) +2 (write-char #!) (prin1 (class-name (class-of error))) (write-char #!)))))

(define-formulate-command com-describe-error ((err 'formula-error :gesture :select)) - (setf *error-formulator* (formula-error-formulator err)) (present (formula-error-error err) t) (format t "~&while computing ~A" (formulate::formulator-formula (formula-error-formulator err)))) + +;;;; +;;;; LAUNCHER ENTRY POINT +;;;; + +(defun run () + (clim-sys:make-process + (lambda () + (clim:run-frame-top-level + (clim:make-application-frame "Formulate" + :frame-class 'formulate.clim-ui:formulate))))) \ No newline at end of file --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/formulate.clim-ui.asd 2009/11/19 01:17:18 1.1 +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/formulate.clim-ui.asd 2009/12/25 21:03:22 1.2 @@ -3,5 +3,6 @@ ((:file "package") (:file "application" :depends-on ("package")) (:file "variables" :depends-on ("package" "application")) - (:file "objects" :depends-on ("package" "application"))) + (:file "objects" :depends-on ("package" "application")) + (:file "classes" :depends-on ("package" "application"))) :depends-on (:formulate :clim)) --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/objects.lisp 2009/11/24 10:06:47 1.2 +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/objects.lisp 2009/12/25 21:03:22 1.3 @@ -1,40 +1,16 @@ (in-package :formulate.clim-ui)

-(define-formulate-command (com-define-formulated-class :name "Define Class") - ((name 'symbol :prompt "Name") - (superclasses '(sequence symbol) :default () :prompt "Superclasses") - (slots '(sequence slot-specification) :prompt "Slots")) - (eval `(defclass ,name ,(coerce superclasses 'list) - (,@(coerce slots 'list)) - (:metaclass formulated-class)))) - -(define-presentation-type slot-specification () - :inherit-from 'expression) - -(define-presentation-method accept ((type slot-specification) stream view - &key default) - (let* ((name (if default - (accept 'symbol :prompt "Name" :default (first default)) - (accept 'symbol :prompt "Name"))) - (formula-p (accept 'boolean - :prompt "Formula?" - :default (getf default 'formula-p t) - :default-type 'boolean)) - (initform (accept 'expression :prompt (if formula-p "Formula" "Initial value")))) - `(,name formula-p ,formula-p :initform ,initform))) - (define-formulate-command (com-create-instance :name "Create Instance") - ((class '(or class symbol) :prompt "Class")) - (vector-push-extend (make-instance class) + ((name 'symbol :prompt "Name") + (class '(or class symbol) :prompt "Class")) + (proclaim `(special ,name)) + (setf (symbol-value name) (make-instance class)) + (vector-push-extend name (monitored-values *application-frame*)))

(define-presentation-type formulated-object () :inherit-from t)

-(defmethod display-monitored-value ((object standard-object)) - (fresh-line) - (present object 'formulated-object)) - (define-presentation-type formulated-slot () ;; 3 element list: (slot-value <object> <slot-name>) :inherit-from t) @@ -54,21 +30,22 @@

(define-presentation-method present (object (type formulated-object) stream view &key) - (with-output-as-presentation (stream object 'formulated-object) + (with-output-as-presentation (stream object 'formulated-object :single-box t) (with-output-as-presentation (stream (class-of object) 'class) - (with-text-face (stream :bold) - (prin1 (class-name (class-of object)) stream))) + (with-text-face (stream :bold) + (with-drawing-options (t :ink +blue+) + (prin1 (class-name (class-of object)) stream)))) (fresh-line stream) (formatting-table (stream) (dolist (slot (class-slots (class-of object))) (with-output-as-presentation (stream `(slot-value ,object ',(slot-definition-name slot)) - 'formulated-slot) + 'formulated-slot + :single-box t) (display-slot-as-row object slot stream view))))))

(define-presentation-translator slot-accessor (formulated-slot form formulate) (object) - (format t "translating slot to expression") (values object 'expression t))

(define-formulate-command (com-remove-object :name "Remove Object From Monitor") @@ -77,7 +54,7 @@

(define-formulate-command (com-set-slot-value :name "Set Slot Value") ((expression 'formulated-slot :prompt "Slot" :gesture :select) - (new-value 'form :prompt "New value" :default *unsupplied-argument-marker*)) + (new-value 'form :prompt "New value")) (destructuring-bind (s-v object (q slot)) expression (declare (ignore s-v q)) (setf (slot-value object slot) (eval new-value)))) --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/variables.lisp 2009/11/24 10:06:47 1.2 +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/variables.lisp 2009/12/25 21:03:22 1.3 @@ -3,10 +3,10 @@ (define-formulate-command (com-define-formulated-variable :name "Define Variable") ((name 'symbol :prompt "Name") (formula-p 'boolean :prompt "Formula?") - (formula 'expression :prompt (if formula-p "Formula" "Initial value")) + (formula 'form :prompt (if formula-p "Formula" "Initial value")) (monitor-p 'boolean :default t :prompt "Show in monitor pane?") - (declarations 'expression :default '() :prompt "Declarations") - (documentation '(or string null) :default nil :prompt "Documentation")) + (declarations 'expression :default '((optimize (speed 1))) :prompt "Declarations") + (documentation '(or string null) :default "" :prompt "Documentation")) (eval `(define-formulated-variable ,name ,formula :formula-p ,formula-p :declare ,declarations :documentation ,documentation)) @@ -15,15 +15,27 @@ (vector-push-extend name (monitored-values *application-frame*)))))

(define-presentation-type formulated-variable () - :inherit-from t) + :inherit-from 'symbol)

(defmethod display-monitored-value ((name symbol)) (fresh-line) - (with-output-as-presentation (t name 'formulated-variable) - (with-text-face (t :bold) - (present name 'symbol)) - (write-string " = ") - (display-formula-value (eval name)))) + (with-output-as-presentation (t name (if (formulated-variable-p name) 'formulated-variable 'symbol) :single-box t) + (formatting-table () + (formatting-row () + (formatting-cell () + (with-text-face (t :bold) + (present name 'symbol)) + (write-string " = ")) + (formatting-cell () + (display-formula-value (eval name))))) + (when (documentation name 'variable) + (fresh-line) + (with-text-face (t :italic) + (with-drawing-options (t :ink +dark-green+) + (filling-output (t) + (write-string (documentation name 'variable))))))) + (terpri) + (terpri))

(define-formulate-command (com-remove-variable :name "Remove Variable From Monitor") ((name 'formulated-variable :prompt "Variable" :gesture :menu)) @@ -31,7 +43,7 @@

(define-formulate-command (com-set-variable :name "Set Variable") ((name 'formulated-variable :gesture :select) - (new-value 'form)) + (new-value 'expression)) (eval `(setf ,name ',new-value)))

(define-formulate-command (com-describe-variable :name "Describe Variable")

--- /project/rjain-utils/cvsroot/formulate/src/clim-ui/classes.lisp 2009/12/25 21:03:22 NONE +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/classes.lisp 2009/12/25 21:03:22 1.1 (in-package :formulate.clim-ui)

(define-application-frame class-definer () ((formulate-application :initarg :formulate-application :accessor formulate-application) (class-name :initarg :class-name :accessor name) (direct-superclasses :initarg :direct-superclasses :initform () :accessor direct-superclasses) (slots :initarg :direct-slots :initform () :accessor direct-slots) (options :initarg :options :initform '((:metaclass formulated-class)) :accessor options)) (:pointer-documentation t) (:top-level (class-definer-top-level)) (:geometry :width 500 :height 500) (:panes (class :application :scroll-bars t :display-function 'display-class-definition :display-time :command-loop) (interactor :interactor :scroll-bars t)) (:layouts (initial (:fill class) (horizontally (:x-spacing 10 :max-width 1000) (make-pane 'push-button :label "Define Class" :show-as-default t :activate-callback (lambda (gadget) (declare (ignore gadget)) (eval-define-class *application-frame*) (redisplay-frame-pane (formulate-application *application-frame*) 'monitor) (frame-exit *application-frame*))) (make-pane 'push-button :label "Cancel" :activate-callback (lambda (gadget) (declare (ignore gadget)) (frame-exit *application-frame*))))) (interacting (2/5 class) (3/5 interactor))))

(define-formulate-command (com-define-formulated-class :name "Define Class") ((name 'symbol :prompt "Name")) (let ((package *package*) (formulate-application *application-frame*) (dialog-name (format nil "Define Class: ~A" name))) (clim-sys:make-process (lambda () (let ((*package* package)) (run-frame-top-level (apply #'make-application-frame dialog-name :frame-class 'class-definer :formulate-application formulate-application :class-name name (when (find-class name nil) (let ((class (find-class name))) (list :direct-superclasses (mapcar #'class-name (class-direct-superclasses class)) :direct-slots (mapcar #'make-slot-specification (class-direct-slots class)) :options (list (list :metaclass (class-name (class-of class))))))))))) :name dialog-name)))

(defvar *setting-layout* nil)

(defmethod layout-frame ((frame class-definer) &optional width height) (if *setting-layout* nil #+nil ;; TODO need to figure out how to get relayout to happen without resizing frame (allocate-space (frame-top-level-sheet frame) (graft-width (frame-top-level-sheet frame)) (graft-height (frame-top-level-sheet frame))) (if (or width height) (call-next-method) (let* ((sr-initial (compose-space (climi::find-pane-for-layout 'initial frame))) (sr-interacting (compose-space (climi::find-pane-for-layout 'interacting frame))) (combined-sr (space-requirement-combine #'max sr-initial sr-interacting))) (call-next-method frame (space-requirement-width combined-sr) (space-requirement-height combined-sr))))))

(defmethod (setf frame-current-layout) :around (name (frame class-definer)) (let ((*setting-layout* t)) (call-next-method)))

(defun accept-without-interactor (frame type) (with-input-context (type) (object) (loop (read-gesture :stream (get-frame-pane frame 'class))) (t object)))

(defvar *interaction-continuation* nil)

(defun do-interaction () (let* ((interactor (get-frame-pane *application-frame* 'interactor)) (*standard-input* interactor) (*standard-output* interactor) (*query-io* interactor)) (window-clear (get-frame-pane *application-frame* 'interactor)) (unwind-protect (funcall *interaction-continuation*) (setf *interaction-continuation* nil) (setf (frame-current-layout *application-frame*) 'initial))))

(defun get-command () (let ((command (accept-without-interactor *application-frame* `(command :command-table ,(frame-command-table *application-frame*))))) (execute-frame-command *application-frame* command)))

(defun class-definer-top-level (*application-frame*) (redisplay-frame-panes *application-frame* :force-p t) ;; limit scope of changes to *INTERACTION-CONTINUATION* to this ;; specific invocation (let ((*interaction-continuation* nil)) (loop (restart-case (progn (redisplay-frame-panes *application-frame*) (if (print *interaction-continuation*) (do-interaction) (get-command))) (abort () :report "Return to application command loop" (clim-extensions:frame-display-pointer-documentation-string *application-frame* "Command aborted."))))))

(defmacro with-interaction (() &body body) `(progn (setf *interaction-continuation* (lambda () ,@body)) (handler-case ;; the following may exit non-locally back to the top-level loop (setf (frame-current-layout *application-frame*) 'interacting) (climi::frame-layout-changed ())) (do-interaction)))

(defun eval-define-class (definer) (eval `(defclass ,(name definer) ,(direct-superclasses definer) ,(mapcar #'slot-specification-form (direct-slots definer)) ,@(options definer))))

(define-presentation-type slot-specification () :inherit-from 't)

(defstruct (slot-specification (:constructor %make-slot-specification (name &key formula-p initform accessor options))) name formula-p initform accessor options)

(defmethod make-slot-specification ((slotd direct-slot-definition) &rest keys) (declare (ignore keys)) (%make-slot-specification (slot-definition-name slotd) :formula-p (subtypep (formulate::formulator-class slotd) 'formulate::formula-formulator-sink) :initform (slot-definition-initform slotd) :accessor (first (slot-definition-readers slotd)) :options nil))

(defmethod make-slot-specification ((name symbol) &rest keys) (apply #'%make-slot-specification name keys))

(defun slot-specification-form (spec) (list* (slot-specification-name spec) 'formula-p (slot-specification-formula-p spec) :initform (slot-specification-initform spec) :accessor (slot-specification-accessor spec) (slot-specification-options spec)))

(define-presentation-method present ((spec slot-specification) (type slot-specification) *standard-output* view &key) (present (slot-specification-name spec)) (with-text-face (t :italic) (prin1 " Formula?: ")) (present (slot-specification-formula-p spec) 'boolean) (with-text-face (t :italic) (if (slot-specification-formula-p spec) (prin1 " Formula: ") (prin1 " Initial Value: "))) (present (slot-specification-initform spec) 'form) (with-text-face (t :italic) (prin1 " Accessor: ")) (present (slot-specification-accessor spec) 'symbol) (with-text-face (t :italic) (prin1 " Options: ")) (present (slot-specification-options spec) 'form))

(define-presentation-translator peer-accessor (slot-specification form class-definer) (object) (values `(my ,(slot-specification-name object)) 'expression t))

(define-presentation-translator peer-accessor (formulated-slot form class-definer) (object) (values `(my ,(second (third object))) 'expression t))

(define-presentation-method accept ((type slot-specification) *standard-output* view &key default) (let (name formula-p initform accessor options) (accepting-values () (fresh-line) (setf name (apply #'accept 'symbol :prompt "Name" (when default (list :default (slot-specification-name default))))) (terpri) (setf formula-p (accept 'boolean :prompt "Formula?" :default (if default (slot-specification-formula-p default) t))) (terpri) (setf initform (apply #'accept 'expression :prompt (if formula-p "Formula" "Initial Value") :query-identifier :initform (when default (list :default (slot-specification-initform default))))) (terpri) (setf accessor (apply #'accept 'symbol :prompt "Accessor" (when default (list :default (slot-specification-accessor default))))) (terpri) (setf options (accept 'expression :prompt "Options" :default (if default (slot-specification-options default) nil)))) (make-slot-specification name :formula-p formula-p :initform initform :accessor accessor :options options)))

(define-modify-macro nconcf (place &rest lists) nconc)

(defun add-superclass (gadget) (declare (ignore gadget)) (with-interaction () (let ((class (accept 'symbol))) (nconcf (direct-superclasses *application-frame*) (list class)))))

(defun add-slot (gadget) (declare (ignore gadget)) (with-interaction () (let ((slot (accept 'slot-specification))) (nconcf (direct-slots *application-frame*) (list slot)))))

(defun add-option (gadget) (declare (ignore gadget)) (with-interaction () (let ((option (accept 'form))) (nconcf (options *application-frame*) (list option)))))

(define-presentation-type superclass () :inherit-from 'class)

(define-class-definer-command (com-remove-superclass) ((superclass 'superclass :gesture :describe)) (setf (direct-superclasses *application-frame*) (remove superclass (direct-superclasses *application-frame*))))

(define-class-definer-command (com-change-superclass) ((superclass 'superclass :gesture :select)) (with-interaction () (setf (direct-superclasses *application-frame*) (substitute (direct-superclasses *application-frame*) (accept 'symbol :default superclass :prompt "New Superclass") superclass))))

(define-class-definer-command (com-remove-slot) ((slot 'slot-specification :gesture :describe)) (setf (direct-slots *application-frame*) (remove slot (direct-slots *application-frame*))))

(define-class-definer-command (com-change-slot) ((slot 'slot-specification :gesture :select)) (with-interaction () (setf (direct-slots *application-frame*) (substitute (accept 'slot-specification :default slot) slot (direct-slots *application-frame*)))))

(define-presentation-type class-option () :inherit-from 'expression)

(define-presentation-method presentation-typep ((object cons) (type class-option)) (and (symbolp (car object)) (consp (cdr object))))

(define-class-definer-command (com-remove-option) ((option 'class-option :gesture :describe)) (setf (options *application-frame*) (remove option (options *application-frame*))))

(define-class-definer-command (com-change-option) ((option 'class-option :gesture :select)) (with-interaction () (setf (options *application-frame*) (substitute (accept 'class-option :default option) option (options *application-frame*)))))

(defun display-class-definition (*application-frame* *standard-output*) (with-look-and-feel-realization (*default-frame-manager* *application-frame*) (let ((interacting (eql (frame-current-layout *application-frame*) 'interacting))) (macrolet ((labelling ((&key label (newline-p t)) &body body) `(surrounding-output-with-border (t) (with-text-face (t :bold) (princ ,label)) (write-char #:) ,(if newline-p `(terpri) `(write-char #\space)) ,@body))) (labelling (:label "Class Name" :newline-p nil) (princ (name *application-frame*))) (terpri) (labelling (:label "Superclasses") (filling-output (t) (dolist (super (direct-superclasses *application-frame*)) (with-output-as-presentation (t super 'superclass) (princ super)) (write-char #\Space))) (fresh-line) (with-output-as-gadget (t) (make-pane 'push-button :label "Add" :id 'add-superclass :activate-callback #'add-superclass :active-p (not interacting)))) (terpri) (labelling (:label "Slots") (dolist (spec (direct-slots *application-frame*)) (present spec 'slot-specification :single-box t) (terpri)) (with-output-as-gadget (t) (make-pane 'push-button :label "Add" :id 'add-slot :activate-callback #'add-slot :active-p (not interacting)))) (terpri) (labelling (:label "Options") (dolist (option (options *application-frame*)) (present option 'class-option) (terpri))

[4 lines skipped]