Commit d651bd17 authored by David O'Toole's avatar David O'Toole

rework dialog definers again

parent 12322989
;; Captions and labels
;; [[file:~/xelf/gui.org::*Captions%20and%20labels][Captions and labels:1]]
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Captions%20and%20labels][Captions and labels:1]]
(in-package :xelf)
(defmethod set-caption-string ((self node) caption)
......@@ -40,7 +40,7 @@
;; Shell operations
;; [[file:~/xelf/gui.org::*Shell%20operations][Shell operations:1]]
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Shell%20operations][Shell operations:1]]
(defmethod drag ((self shell) x y)
(with-slots (target-x target-y) self
(setf target-x (- x (window-x)))
......@@ -165,7 +165,7 @@
;; Automatic layout
;; [[file:~/xelf/gui.org::*Automatic%20layout][Automatic layout:1]]
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Automatic%20layout][Automatic layout:1]]
(defmethod update :after ((self shell))
(layout self)
(mapc #'layout (%inputs self))
......@@ -178,18 +178,20 @@
;; System object
;; [[file:~/xelf/gui.org::*System%20object][System object:1]]
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*System%20object][System object:1]]
(defvar *system* nil)
(defclass system (node)
((type :initform :system)
(running :initform nil)))
(defun show-dialog (dialog title)
(defun show-dialog (dialog title &optional instance)
(let ((frame (make-frame title dialog)))
(add-node (current-buffer) frame)
(center frame)
(freeze dialog)
(when instance
(setf (slot-value dialog 'instance) instance))
nil))
(defun edit-cut ()
......@@ -260,28 +262,30 @@
;; User dialogs
;; [[file:~/xelf/gui.org::*User%20dialogs][User dialogs:1]]
(define-dialog rename-buffer
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*User%20dialogs][User dialogs:1]]
(define-command-dialog rename-buffer
((new-name (slot-value (current-buffer) 'buffer-name)))
(rename (current-buffer) new-name))
(rename (current-buffer) (arg 'new-name)))
(define-dialog resize-buffer
(define-command-dialog resize-buffer
((width (slot-value (current-buffer) 'width))
(height (slot-value (current-buffer) 'height)))
(resize (current-buffer) width height))
(resize (current-buffer)
(arg 'width)
(arg 'height)))
(define-dialog visit-buffer
(define-command-dialog visit-buffer
((buffer-name (or (first *buffer-history*)
(buffer-name (current-buffer)))))
(switch-to-buffer buffer-name))
(switch-to-buffer (arg 'buffer-name)))
(define-dialog create-buffer
(define-command-dialog create-buffer
((buffer-name (uniquify-buffer-name "*untitled-buffer*")))
(switch-to-buffer (make-instance 'buffer :name buffer-name)))
(switch-to-buffer (make-instance 'buffer :name (arg 'buffer-name))))
(define-dialog paste-as-new-buffer
(define-command-dialog paste-as-new-buffer
((buffer-name (uniquify-buffer-name "*pasted-buffer*")))
(switch-to-buffer (make-instance 'buffer :name buffer-name))
(switch-to-buffer (make-instance 'buffer :name (arg 'buffer-name)))
(paste (current-buffer))
(trim (current-buffer)))
;; User dialogs:1 ends here
......@@ -289,7 +293,7 @@
;; Menu bar structure
;; [[file:~/xelf/gui.org::*Menu%20bar%20structure][Menu bar structure:1]]
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Menu%20bar%20structure][Menu bar structure:1]]
(defparameter *project-menu*
'(:label "Project"
:inputs
......@@ -445,7 +449,7 @@
;; Menubar class
;; [[file:~/xelf/gui.org::*Menubar%20class][Menubar class:1]]
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Menubar%20class][Menubar class:1]]
(defclass menubar (tree)
((category :initform :menu)
(temporary :initform t)))
......@@ -559,7 +563,7 @@
;; Floating window frames
;; [[file:~/xelf/gui.org::*Floating%20window%20frames][Floating window frames:1]]
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Floating%20window%20frames][Floating window frames:1]]
(define-handle frame-close-button :close
:slots ((target-frame :initform nil :initarg :target-frame :accessor target-frame)))
......@@ -626,7 +630,7 @@
;; Context menus
;; [[file:~/xelf/gui.org::*Context%20menus][Context menus:1]]
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Context%20menus][Context menus:1]]
(defmethod make-method-menu-item ((self node) method target)
(assert (and target (keywordp method)))
(let ((method-string (pretty-string method)))
......
This diff is collapsed.
......@@ -4392,10 +4392,12 @@ supported compiler.
(command-argument-string (thing)
(concatenate 'string (command-name-string thing) ": "))
(action-name () (intern (concatenate 'string (symbol-name name) "-ACTION")))
(show-name () (intern (concatenate 'string "SHOW-" (symbol-name name))))
(show-name () (intern (concatenate 'string "SHOW-" (symbol-name name) "-DIALOG")))
(dialog-class-name () (intern (concatenate 'string (symbol-name name) "-DIALOG"))))
,@body))
(defvar *instance* nil)
(defmacro define-dialog (name arglist &body body)
(with-dialog-definers
`(progn
......@@ -4403,7 +4405,8 @@ supported compiler.
(export ',(action-name))
(defun ,(show-name) (&rest args)
(show-dialog (apply #'make-instance ',(dialog-class-name) args)
,(command-name-string name)))
,(command-name-string name)
*instance*))
(export ',(show-name))
(define-visual-macro ,(dialog-class-name)
(:super phrase
......@@ -4422,19 +4425,20 @@ supported compiler.
;; from the dialog box
(%inputs (first (slot-value self 'inputs)))))))))))
(defmacro define-command-dialog (name arglist &body body)
`(define-dialog ,name ,arglist
(labels ((arg (name) (getf ^args^ name)))
,@body)))
(defmacro define-properties-dialog (name slots &body body)
(let ((instance (gensym)))
(labels ((place-form (slot) `(slot-value ,instance ',slot))
(init-form (slot) `(,slot ,(place-form slot)))
(setf-form (slot value) `(setf ,(place-form slot) ,value)))
`(progn
(define-dialog ,name ,(mapcar #'init-form slots)
(loop while ^args^ do
(let ((slot (pop ^args^))
(value (pop ^args^)))
(setf (slot-value ,instance slot) value))))
(defmethod initialize-instance :after ((self ,name) &key instance)
(setf ,instance instance))))))
(labels ((place-form (slot) `(slot-value ,instance ',slot))
(init-form (slot) `(,slot ,(place-form slot)))
(setf-form (slot value) `(setf ,(place-form slot) ,value)))
`(define-dialog ,name ,(mapcar #'init-form slots)
(loop while ^args^ do
(let ((slot (pop ^args^))
(value (pop ^args^)))
(setf (slot-value self slot) value))))))
(defparameter *minimum-shell-width* 400)
(defparameter *shell-background-color* "gray20")
......@@ -4661,11 +4665,14 @@ supported compiler.
((type :initform :system)
(running :initform nil)))
(defun show-dialog (dialog title)
(defun show-dialog (dialog title &optional instance)
(let ((frame (make-frame title dialog)))
(add-node (current-buffer) frame)
(center frame)
(freeze dialog)
(mapc #'freeze (inputs dialog))
(when instance
(setf (slot-value dialog 'instance) instance))
nil))
(defun edit-cut ()
......@@ -4736,27 +4743,29 @@ supported compiler.
** User dialogs
#+begin_src lisp :tangle commands.lisp
(define-dialog rename-buffer
(define-command-dialog rename-buffer
((new-name (slot-value (current-buffer) 'buffer-name)))
(rename (current-buffer) new-name))
(rename (current-buffer) (arg 'new-name)))
(define-dialog resize-buffer
(define-command-dialog resize-buffer
((width (slot-value (current-buffer) 'width))
(height (slot-value (current-buffer) 'height)))
(resize (current-buffer) width height))
(resize (current-buffer)
(arg 'width)
(arg 'height)))
(define-dialog visit-buffer
(define-command-dialog visit-buffer
((buffer-name (or (first *buffer-history*)
(buffer-name (current-buffer)))))
(switch-to-buffer buffer-name))
(switch-to-buffer (arg 'buffer-name)))
(define-dialog create-buffer
(define-command-dialog create-buffer
((buffer-name (uniquify-buffer-name "*untitled-buffer*")))
(switch-to-buffer (make-instance 'buffer :name buffer-name)))
(switch-to-buffer (make-instance 'buffer :name (arg 'buffer-name))))
(define-dialog paste-as-new-buffer
(define-command-dialog paste-as-new-buffer
((buffer-name (uniquify-buffer-name "*pasted-buffer*")))
(switch-to-buffer (make-instance 'buffer :name buffer-name))
(switch-to-buffer (make-instance 'buffer :name (arg 'buffer-name)))
(paste (current-buffer))
(trim (current-buffer)))
#+end_src
......
;; Shell workspace (shell.lisp)
;; [[file:~/xelf/gui.org::*Shell%20workspace%20(shell.lisp)][Shell workspace (shell.lisp):1]]
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Shell%20workspace%20(shell.lisp)][Shell workspace (shell.lisp):1]]
(in-package :xelf)
;; Shell workspace (shell.lisp):1 ends here
;; Messenger widget
;; [[file:~/xelf/gui.org::*Messenger%20widget][Messenger widget:1]]
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Messenger%20widget][Messenger widget:1]]
(defclass messenger (node)
((category :initform :terminal)
(messages :initform nil)))
......@@ -64,7 +64,7 @@
;; Modeline
;; [[file:~/xelf/gui.org::*Modeline][Modeline:1]]
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Modeline][Modeline:1]]
(defvar *modeline-status-string* nil)
(defun show-status (string)
......@@ -118,7 +118,7 @@
;; Shell prompt
;; [[file:~/xelf/gui.org::*Shell%20prompt][Shell prompt:1]]
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Shell%20prompt][Shell prompt:1]]
(defclass shell-prompt (entry)
((result :initform nil)
(background :initform nil)
......@@ -157,7 +157,7 @@
;; Interactive dialog boxes
;; [[file:~/xelf/gui.org::*Interactive%20dialog%20boxes][Interactive dialog boxes:1]]
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Interactive%20dialog%20boxes][Interactive dialog boxes:1]]
(defmacro with-dialog-definers (&body body)
`(labels ((arglist-input-forms (argument-forms)
(mapcar #'(lambda (f)
......@@ -182,10 +182,12 @@
(command-argument-string (thing)
(concatenate 'string (command-name-string thing) ": "))
(action-name () (intern (concatenate 'string (symbol-name name) "-ACTION")))
(show-name () (intern (concatenate 'string "SHOW-" (symbol-name name))))
(show-name () (intern (concatenate 'string "SHOW-" (symbol-name name) "-DIALOG")))
(dialog-class-name () (intern (concatenate 'string (symbol-name name) "-DIALOG"))))
,@body))
(defvar *instance* nil)
(defmacro define-dialog (name arglist &body body)
(with-dialog-definers
`(progn
......@@ -193,7 +195,8 @@
(export ',(action-name))
(defun ,(show-name) (&rest args)
(show-dialog (apply #'make-instance ',(dialog-class-name) args)
,(command-name-string name)))
,(command-name-string name)
*instance*))
(export ',(show-name))
(define-visual-macro ,(dialog-class-name)
(:super phrase
......@@ -212,19 +215,20 @@
;; from the dialog box
(%inputs (first (slot-value self 'inputs)))))))))))
(defmacro define-command-dialog (name arglist &body body)
`(define-dialog ,name ,arglist
(labels ((arg (name) (getf ^args^ name)))
,@body)))
(defmacro define-properties-dialog (name slots &body body)
(let ((instance (gensym)))
(labels ((place-form (slot) `(slot-value ,instance ',slot))
(init-form (slot) `(,slot ,(place-form slot)))
(setf-form (slot value) `(setf ,(place-form slot) ,value)))
`(progn
(define-dialog ,name ,(mapcar #'init-form slots)
(loop while ^args^ do
(let ((slot (pop ^args^))
(value (pop ^args^)))
(setf (slot-value ,instance slot) value))))
(defmethod initialize-instance :after ((self ,name) &key instance)
(setf ,instance instance))))))
(labels ((place-form (slot) `(slot-value ,instance ',slot))
(init-form (slot) `(,slot ,(place-form slot)))
(setf-form (slot value) `(setf ,(place-form slot) ,value)))
`(define-dialog ,name ,(mapcar #'init-form slots)
(loop while ^args^ do
(let ((slot (pop ^args^))
(value (pop ^args^)))
(setf (slot-value self slot) value))))))
(defparameter *minimum-shell-width* 400)
(defparameter *shell-background-color* "gray20")
......
......@@ -30,3 +30,4 @@
(start-game plong)))))
(test-gui)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment