Commit 965ea446 authored by David O'Toole's avatar David O'Toole

dialog boxes working

parent ed7864c3
......@@ -223,7 +223,8 @@
(export ',(action-name name))
(defun ,(show-name name) (&rest args)
(show-dialog (apply #'make-instance ',(dialog-class-name name) args)
,(command-name-string name)))
,(command-name-string name)
:destroy-after-evaluate-p t))
(export ',(show-name name))
(define-visual-macro ,(dialog-class-name name)
(:super dialog
......@@ -273,6 +274,9 @@
(defmethod find-tab-proxy ((entry property-value-entry))
(parent entry))
(defmethod evaluate ((entry property-value-entry))
(get-value entry))
(defmethod draw-background ((self property-row) &key color)
(with-slots (x y width height) self
(draw-patch self x y (+ x width) (+ y height) :depressed nil :style :rounded)))
......@@ -341,7 +345,8 @@
`(progn
(defun ,(show-name name) (&optional (instance *instance*))
(show-dialog (make-instance ',(dialog-class-name name) :instance instance)
,(command-name-string name)))
,(command-name-string name)
:destroy-after-evaluate-p nil))
(defclass ,(dialog-class-name name) (property-sheet)
((properties :initform ',slot-names)))))
;; Dialog box builder:1 ends here
......@@ -364,8 +369,8 @@
(defmethod remove-widget ((buffer buffer) (node node))
(delete-input buffer node))
(defun show-dialog (dialog title)
(let ((frame (make-frame title dialog)))
(defun show-dialog (dialog title &key destroy-after-evaluate-p)
(let ((frame (make-frame title dialog :destroy-after-evaluate-p destroy-after-evaluate-p)))
(add-node (current-buffer) frame)
(center frame)
(align-to-pixels frame)
......@@ -442,14 +447,14 @@
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*User%20dialogs][User dialogs:1]]
(define-dialog rename-buffer
((new-name (slot-value (current-buffer) 'buffer-name)))
(rename (current-buffer) new-name))
;; (define-dialog rename-buffer
;; ((new-name (slot-value (current-buffer) 'buffer-name)))
;; (rename-buffer (current-buffer) new-name))
(define-dialog resize-buffer
((width (slot-value (current-buffer) 'width))
(height (slot-value (current-buffer) 'height)))
(resize (current-buffer) width height))
;; (define-dialog resize-buffer
;; ((width (slot-value (current-buffer) 'width))
;; (height (slot-value (current-buffer) 'height)))
;; (resize (current-buffer) width height))
(define-dialog visit-buffer
((buffer-name (or (first *buffer-history*)
......@@ -457,18 +462,20 @@
(switch-to-buffer buffer-name))
(define-dialog create-buffer
((buffer-name (uniquify-buffer-name "*untitled-buffer*")))
(switch-to-buffer (make-instance 'buffer :buffer-name buffer-name)))
((buffer-name (uniquify-buffer-name "*untitled-buffer*"))
(buffer-class 'buffer))
(at-next-update
(switch-to-buffer (make-instance buffer-class :buffer-name buffer-name))))
(define-dialog paste-as-new-buffer
((buffer-name (uniquify-buffer-name "*pasted-buffer*"))
(offset-x 0)
(offset-y 0))
(at-next-update
(add-buffer buffer-name (make-instance 'buffer))
(switch-to-buffer buffer-name)
(paste (current-buffer))
(trim-conservatively (current-buffer))))
(let ((buffer (make-instance 'buffer :buffer-name buffer-name)))
(switch-to-buffer buffer-name)
(paste (current-buffer))
(trim-conservatively (current-buffer)))))
(define-properties-dialog buffer-properties
(buffer-name width height z-sort-p background-image background-color
......@@ -816,6 +823,10 @@
(spacing :initform 2)
(dash :initform 1)
(style :initform :rounded)
(destroy-after-evaluate-p
:initform t
:initarg :destroy-after-evaluate-p
:accessor destroy-after-evaluate-p)
(category :initform :system))
:inputs (:titlebar (make-instance 'titlebar)
:content (make-instance 'label :read-only t))))
......@@ -828,8 +839,8 @@
(with-slots (inputs) self
(setf (second inputs) content)))
(defun make-frame (title content)
(let ((frame (make-instance 'frame)))
(defun make-frame (title content &key destroy-after-evaluate-p)
(let ((frame (make-instance 'frame :destroy-after-evaluate-p destroy-after-evaluate-p)))
(prog1 frame
(set-title frame title)
(set-content frame content)
......@@ -849,6 +860,10 @@
(defmethod evaluate ((frame frame))
(evaluate (second (inputs frame))))
(defmethod evaluate :after ((frame frame))
(when (destroy-after-evaluate-p frame)
(destroy frame)))
(defmethod context-menu ((frame frame))
(context-menu (second (inputs frame))))
......
......@@ -18,7 +18,9 @@
(z-sort-p :initform t :initarg :z-sort-p :accessor z-sort-p
:documentation "When non-nil, draw objects in correct Z-order.")
(selection :initform nil)
(buffer-name :initform nil :accessor buffer-name :initarg :buffer-name)
(buffer-name :initform "*untitled*"
:accessor buffer-name
:initarg :buffer-name)
(variables :initform nil :accessor variables :initarg :variables)
(point :initform nil)
(modified-p :initform nil)
......@@ -78,19 +80,27 @@
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Initialization][Initialization:1]]
(defmethod initialize-instance :after ((self buffer) &key)
(defmethod ensure-unique-buffer-name ((buffer buffer))
(setf (buffer-name buffer) (uniquify-buffer-name (buffer-name buffer))))
(defmethod install-shell-keybindings ((self buffer))
(bind-event self '(:f1) 'show-help-command)
(bind-event self '(:h :control) 'show-help-command)
(bind-event self '(:c :control) 'edit-copy)
(bind-event self '(:x :control) 'edit-cut)
(bind-event self '(:v :control) 'edit-paste)
(bind-event self '(:v :shift :control) 'paste-at-pointer)
(bind-event self '(:tab) 'tab)
(bind-event self '(:tab :control) 'backtab)
(bind-event self '(:g :control) 'close-shell)
(bind-event self '(:escape) 'close-shell)
(bind-event self '(:x :alt) 'open-shell))
(defmethod initialize-instance :after ((self buffer) &key)
(ensure-unique-buffer-name self)
(register-buffer self)
(with-shell
(bind-event self '(:f1) 'show-help-command)
(bind-event self '(:h :control) 'show-help-command)
(bind-event self '(:c :control) 'edit-copy)
(bind-event self '(:x :control) 'edit-cut)
(bind-event self '(:v :control) 'edit-paste)
(bind-event self '(:v :shift :control) 'paste-at-pointer)
(bind-event self '(:tab) 'tab)
(bind-event self '(:tab :control) 'backtab)
(bind-event self '(:g :control) 'close-shell)
(bind-event self '(:escape) 'close-shell)
(bind-event self '(:x :alt) 'open-shell)))
(install-shell-keybindings self)))
(defmacro define-buffer (name &body body)
`(defclass ,name (buffer)
......@@ -204,26 +214,29 @@
;; Handling buffers:1 ends here
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Handling%20buffers][Handling buffers:2]]
(defun add-buffer (name object)
(assert (xelfp object))
(defun register-buffer (buffer)
(when (null *buffers*)
(initialize-buffers))
(prog1 t
(setf (buffer-name object) name)
(setf (gethash name *buffers*)
(find-uuid object))))
(setf (gethash (buffer-name buffer)
*buffers*)
buffer)))
(defun find-buffer (name &key create class noerror)
(find-object
(or (gethash name *buffers*)
(if create
(let ((buffer (make-instance (or class 'buffer))))
(prog1 buffer (add-buffer name buffer)))
(prog1 buffer (register-buffer buffer)))
(unless noerror
(error "Cannot find buffer ~S" name))))))
(defun kill-buffer (name)
(defun unregister-buffer (name)
(remhash name *buffers*))
(defun kill-buffer (name)
(destroy (find-buffer name))
(unregister-buffer name))
;; Handling buffers:2 ends here
;; Handling buffer names
......@@ -245,9 +258,9 @@
(defmethod rename-buffer ((self buffer) name)
(assert (stringp name))
(when (find-buffer name :noerror t)
(kill-buffer name))
(add-buffer name self))
(setf (buffer-name self) name)
(ensure-unique-buffer-name self)
(register-buffer self))
;; Handling buffer names:1 ends here
;; Buffers associated with a file
......@@ -717,7 +730,7 @@
(defun make-clipboard ()
(let ((clipboard (make-instance 'buffer :buffer-name "*clipboard*")))
(add-buffer "*clipboard*" clipboard)
(register-buffer clipboard)
clipboard))
;; Copy, cut, and paste:1 ends here
......@@ -2808,7 +2821,7 @@ See sidebar for more commands to try.
(font-text-width (slot-value self 'label) *font*))))
(defmethod draw-label ((self node))
(draw-label-string self (fancy-format-expression (label-string expression))))
(draw-label-string self (fancy-format-expression (label-string self))))
(defun expression-width (expression &optional (font *font*))
(if (xelf::object-p expression)
......
......@@ -70,7 +70,9 @@ every BUFFER is also a NODE.)
(z-sort-p :initform t :initarg :z-sort-p :accessor z-sort-p
:documentation "When non-nil, draw objects in correct Z-order.")
(selection :initform nil)
(buffer-name :initform nil :accessor buffer-name :initarg :buffer-name)
(buffer-name :initform "*untitled*"
:accessor buffer-name
:initarg :buffer-name)
(variables :initform nil :accessor variables :initarg :variables)
(point :initform nil)
(modified-p :initform nil)
......@@ -129,19 +131,27 @@ every BUFFER is also a NODE.)
** Initialization
#+begin_src lisp
(defmethod ensure-unique-buffer-name ((buffer buffer))
(setf (buffer-name buffer) (uniquify-buffer-name (buffer-name buffer))))
(defmethod install-shell-keybindings ((self buffer))
(bind-event self '(:f1) 'show-help-command)
(bind-event self '(:h :control) 'show-help-command)
(bind-event self '(:c :control) 'edit-copy)
(bind-event self '(:x :control) 'edit-cut)
(bind-event self '(:v :control) 'edit-paste)
(bind-event self '(:v :shift :control) 'paste-at-pointer)
(bind-event self '(:tab) 'tab)
(bind-event self '(:tab :control) 'backtab)
(bind-event self '(:g :control) 'close-shell)
(bind-event self '(:escape) 'close-shell)
(bind-event self '(:x :alt) 'open-shell))
(defmethod initialize-instance :after ((self buffer) &key)
(ensure-unique-buffer-name self)
(register-buffer self)
(with-shell
(bind-event self '(:f1) 'show-help-command)
(bind-event self '(:h :control) 'show-help-command)
(bind-event self '(:c :control) 'edit-copy)
(bind-event self '(:x :control) 'edit-cut)
(bind-event self '(:v :control) 'edit-paste)
(bind-event self '(:v :shift :control) 'paste-at-pointer)
(bind-event self '(:tab) 'tab)
(bind-event self '(:tab :control) 'backtab)
(bind-event self '(:g :control) 'close-shell)
(bind-event self '(:escape) 'close-shell)
(bind-event self '(:x :alt) 'open-shell)))
(install-shell-keybindings self)))
(defmacro define-buffer (name &body body)
`(defclass ,name (buffer)
......@@ -249,26 +259,29 @@ See also "Command shell" below.
#+end_src
#+begin_src lisp
(defun add-buffer (name object)
(assert (xelfp object))
(defun register-buffer (buffer)
(when (null *buffers*)
(initialize-buffers))
(prog1 t
(setf (buffer-name object) name)
(setf (gethash name *buffers*)
(find-uuid object))))
(setf (gethash (buffer-name buffer)
*buffers*)
buffer)))
(defun find-buffer (name &key create class noerror)
(find-object
(or (gethash name *buffers*)
(if create
(let ((buffer (make-instance (or class 'buffer))))
(prog1 buffer (add-buffer name buffer)))
(prog1 buffer (register-buffer buffer)))
(unless noerror
(error "Cannot find buffer ~S" name))))))
(defun kill-buffer (name)
(defun unregister-buffer (name)
(remhash name *buffers*))
(defun kill-buffer (name)
(destroy (find-buffer name))
(unregister-buffer name))
#+end_src
** Handling buffer names
......@@ -289,9 +302,9 @@ See also "Command shell" below.
(defmethod rename-buffer ((self buffer) name)
(assert (stringp name))
(when (find-buffer name :noerror t)
(kill-buffer name))
(add-buffer name self))
(setf (buffer-name self) name)
(ensure-unique-buffer-name self)
(register-buffer self))
#+end_src
** Buffers associated with a file
......@@ -747,7 +760,7 @@ This section is obsolete and will be removed in the future.
(defun make-clipboard ()
(let ((clipboard (make-instance 'buffer :buffer-name "*clipboard*")))
(add-buffer "*clipboard*" clipboard)
(register-buffer clipboard)
clipboard))
#+end_src
......@@ -2820,7 +2833,7 @@ hybrid GUI inspired by MIT Scratch and its derivatives.
(font-text-width (slot-value self 'label) *font*))))
(defmethod draw-label ((self node))
(draw-label-string self (fancy-format-expression (label-string expression))))
(draw-label-string self (fancy-format-expression (label-string self))))
(defun expression-width (expression &optional (font *font*))
(if (xelf::object-p expression)
......@@ -4395,7 +4408,7 @@ supported compiler.
(defmethod update ((self modeline))
(mapc #'pin (slot-value self 'inputs))
(with-visual-slots (buffer-id objects position mode status) self
(set-value buffer-id (or (slot-value (current-buffer) 'buffer-name) "*untitled-buffer*"))
(set-value buffer-id (slot-value (current-buffer) 'buffer-name))
(set-value objects (modeline-database-string
(length (selection))
(hash-table-count (slot-value (current-buffer) 'objects))
......@@ -4769,7 +4782,8 @@ supported compiler.
(export ',(action-name name))
(defun ,(show-name name) (&rest args)
(show-dialog (apply #'make-instance ',(dialog-class-name name) args)
,(command-name-string name)))
,(command-name-string name)
:destroy-after-evaluate-p t))
(export ',(show-name name))
(define-visual-macro ,(dialog-class-name name)
(:super dialog
......@@ -4819,6 +4833,9 @@ supported compiler.
(defmethod find-tab-proxy ((entry property-value-entry))
(parent entry))
(defmethod evaluate ((entry property-value-entry))
(get-value entry))
(defmethod draw-background ((self property-row) &key color)
(with-slots (x y width height) self
(draw-patch self x y (+ x width) (+ y height) :depressed nil :style :rounded)))
......@@ -4887,7 +4904,8 @@ supported compiler.
`(progn
(defun ,(show-name name) (&optional (instance *instance*))
(show-dialog (make-instance ',(dialog-class-name name) :instance instance)
,(command-name-string name)))
,(command-name-string name)
:destroy-after-evaluate-p nil))
(defclass ,(dialog-class-name name) (property-sheet)
((properties :initform ',slot-names)))))
#+end_src
......@@ -4909,8 +4927,8 @@ supported compiler.
(defmethod remove-widget ((buffer buffer) (node node))
(delete-input buffer node))
(defun show-dialog (dialog title)
(let ((frame (make-frame title dialog)))
(defun show-dialog (dialog title &key destroy-after-evaluate-p)
(let ((frame (make-frame title dialog :destroy-after-evaluate-p destroy-after-evaluate-p)))
(add-node (current-buffer) frame)
(center frame)
(align-to-pixels frame)
......@@ -4986,14 +5004,14 @@ supported compiler.
** User dialogs
#+begin_src lisp :tangle commands.lisp
(define-dialog rename-buffer
((new-name (slot-value (current-buffer) 'buffer-name)))
(rename (current-buffer) new-name))
;; (define-dialog rename-buffer
;; ((new-name (slot-value (current-buffer) 'buffer-name)))
;; (rename-buffer (current-buffer) new-name))
(define-dialog resize-buffer
((width (slot-value (current-buffer) 'width))
(height (slot-value (current-buffer) 'height)))
(resize (current-buffer) width height))
;; (define-dialog resize-buffer
;; ((width (slot-value (current-buffer) 'width))
;; (height (slot-value (current-buffer) 'height)))
;; (resize (current-buffer) width height))
(define-dialog visit-buffer
((buffer-name (or (first *buffer-history*)
......@@ -5001,18 +5019,20 @@ supported compiler.
(switch-to-buffer buffer-name))
(define-dialog create-buffer
((buffer-name (uniquify-buffer-name "*untitled-buffer*")))
(switch-to-buffer (make-instance 'buffer :buffer-name buffer-name)))
((buffer-name (uniquify-buffer-name "*untitled-buffer*"))
(buffer-class 'buffer))
(at-next-update
(switch-to-buffer (make-instance buffer-class :buffer-name buffer-name))))
(define-dialog paste-as-new-buffer
((buffer-name (uniquify-buffer-name "*pasted-buffer*"))
(offset-x 0)
(offset-y 0))
(at-next-update
(add-buffer buffer-name (make-instance 'buffer))
(switch-to-buffer buffer-name)
(paste (current-buffer))
(trim-conservatively (current-buffer))))
(let ((buffer (make-instance 'buffer :buffer-name buffer-name)))
(switch-to-buffer buffer-name)
(paste (current-buffer))
(trim-conservatively (current-buffer)))))
(define-properties-dialog buffer-properties
(buffer-name width height z-sort-p background-image background-color
......@@ -5358,6 +5378,10 @@ supported compiler.
(spacing :initform 2)
(dash :initform 1)
(style :initform :rounded)
(destroy-after-evaluate-p
:initform t
:initarg :destroy-after-evaluate-p
:accessor destroy-after-evaluate-p)
(category :initform :system))
:inputs (:titlebar (make-instance 'titlebar)
:content (make-instance 'label :read-only t))))
......@@ -5370,8 +5394,8 @@ supported compiler.
(with-slots (inputs) self
(setf (second inputs) content)))
(defun make-frame (title content)
(let ((frame (make-instance 'frame)))
(defun make-frame (title content &key destroy-after-evaluate-p)
(let ((frame (make-instance 'frame :destroy-after-evaluate-p destroy-after-evaluate-p)))
(prog1 frame
(set-title frame title)
(set-content frame content)
......@@ -5391,6 +5415,10 @@ supported compiler.
(defmethod evaluate ((frame frame))
(evaluate (second (inputs frame))))
(defmethod evaluate :after ((frame frame))
(when (destroy-after-evaluate-p frame)
(destroy frame)))
(defmethod context-menu ((frame frame))
(context-menu (second (inputs frame))))
......
......@@ -93,7 +93,7 @@
(defmethod update ((self modeline))
(mapc #'pin (slot-value self 'inputs))
(with-visual-slots (buffer-id objects position mode status) self
(set-value buffer-id (or (slot-value (current-buffer) 'buffer-name) "*untitled-buffer*"))
(set-value buffer-id (slot-value (current-buffer) 'buffer-name))
(set-value objects (modeline-database-string
(length (selection))
(hash-table-count (slot-value (current-buffer) 'objects))
......
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