[rjain-utils-cvs] CVS formulate/src/clim-ui
rjain
rjain at common-lisp.net
Fri Dec 25 21:03:22 UTC 2009
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 () , at 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))
, at 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]
More information about the Rjain-utils-cvs
mailing list