Commit 4c1f1b7a authored by David O'Toole's avatar David O'Toole

clean up menu

parent 55f039a3
......@@ -192,6 +192,7 @@
(let ((frame (make-frame title dialog)))
(add-node (current-buffer) frame)
(center frame)
(align-to-pixels frame)
(freeze dialog)
(mapc #'freeze (inputs dialog))
nil))
......@@ -293,10 +294,12 @@
(buffer-name width height z-sort-p background-image background-color
window-scrolling-speed horizontal-scrolling-margin vertical-scrolling-margin))
(defmethod apply-properties :after ((dialog buffer-properties-dialog) buffer)
(defmethod apply-properties :after ((dialog buffer-properties-dialog) &optional buffer)
(notify (format nil "Applied buffer properties to ~S." buffer))
(let ((buffer (or buffer (current-buffer))))
(with-slots (height width buffer-name) buffer
(resize buffer width height)
(rename-buffer buffer buffer-name)))
(rename-buffer buffer buffer-name))))
;; User dialogs:1 ends here
;; Menu bar structure
......@@ -601,6 +604,11 @@
(defmethod set-title ((self titlebar) title)
(set-value (input-node self :title) title))
(defmethod tap ((self titlebar) x y)
(let ((it (parent (parent self))))
(when it
(tap it x y))))
(define-visual-macro frame
(:super phrase
:slots ((frozen :initform t)
......@@ -642,6 +650,9 @@
(defmethod evaluate ((frame frame))
(evaluate (second (inputs frame))))
(defmethod context-menu ((frame frame))
(context-menu (second (inputs frame))))
;; (defmethod as-drag ((self menu) x y)
;; (make-menu-frame self))
;; Floating window frames:1 ends here
......@@ -651,27 +662,30 @@
;; [[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)))
(assert (and target method (symbolp method)))
(let ((method-string (pretty-string method)))
(list :label method-string
:pinned t
:locked t
:method method
:target target
:action (new 'task method target))))
:target (find-object target)
:action (make-instance 'task :method-name method :target (find-object target)))))
(defclass context-menu (menu)
((no-background :initform nil)))
(defmethod context-menu ((self node))
(let ((methods (slot-value self 'methods)))
(let (inputs)
(dolist (method (sort methods #'string<))
(push (make-method-menu-item self method (uuid self)) inputs))
(make-menu (list
;; :label
;; (string-downcase
;; (concatenate 'string
;; (get-some-object-name self)
;; " " (object-address-string self)))
:inputs (nreverse inputs)
(flet ((menu-item (args)
(make-menu args :target self)))
(let ((menu (make-instance 'context-menu
:inputs (mapcar #'menu-item (nreverse inputs))
:pinned nil
:expanded t
:locked t)
:target (find-uuid self)))))
:locked t)))
(prog1 menu
(bring-to-front menu)))))))
;; Context menus:1 ends here
......@@ -1885,7 +1885,10 @@ See sidebar for more commands to try.
(defmethod pick ((self halo))
(pick (slot-value self 'target)))
(defmethod tap ((self halo) x y) nil)
(defmethod tap ((self halo) x y)
(toggle-halo (slot-value self 'target)))
(defmethod make-halo ((self halo)) nil)
(defmethod scroll-tap ((self halo) x y)
(toggle-halo (slot-value self 'target)))
......@@ -2279,12 +2282,12 @@ See sidebar for more commands to try.
;; fixme
(defmethod draw :after ((self buffer))
(when *notification*
(draw *notification*))
(when *menubar*
(draw *menubar*))
(when *shell*
(draw *shell*)))
(draw *shell*))
(when *notification*
(draw *notification*)))
(defmethod tap ((self prompt) mouse-x mouse-y)
(declare (ignore mouse-y))
......@@ -3799,14 +3802,14 @@ See sidebar for more commands to try.
(dolist (line lines)
(callf max width (dash 4 (font-text-width line font)))))))
(defmethod notify-style ((self text) &optional (timeout (seconds->frames 10.0)))
(defmethod notify-style ((self text) &optional (timeout (seconds->frames 5.5)))
(setf (slot-value self 'timeout) timeout)
(setf (slot-value self 'category) :system)
(setf (foreground-color self) "black")
(setf (background-color self) "cornsilk")
(layout self)
(move-to self (+ (window-x) 8)
(+ (window-y) 35)))
(move-to self (+ (window-pointer-x) 12)
(- (window-pointer-y) 20)))
(defun recent-messages (&optional (n 5))
(nreverse (subseq *message-history* 0
......@@ -3819,7 +3822,8 @@ See sidebar for more commands to try.
(when *notification*
(remove-object (current-buffer) *notification*)
(setf *notification* notification))
(add-node (current-buffer) notification)))
(add-node (current-buffer) notification)
(bring-to-front notification)))
(defun notify-message-maybe ()
(when *use-notifications*
......@@ -3827,6 +3831,7 @@ See sidebar for more commands to try.
(defun notify (text)
(mapcar #'message (split-string-on-lines text))
(show-status text)
(notify-message text))
(add-hook '*message-hook* #'notify-message-maybe)
......@@ -4140,11 +4145,11 @@ See sidebar for more commands to try.
(defvar *menu-prototype* nil)
(defun make-menu (items &key target)
(defun make-menu (items &key target (class 'menu))
(make-tree items
:target target
:category :menu
:tree-class 'menu))
:tree-class class))
;; menu items should not accept any dragged widgets.
(defmethod accept ((self menu) arg) nil)
......@@ -4236,7 +4241,9 @@ See sidebar for more commands to try.
text
(if (or (functionp action)
(null action)
(fboundp action))
(xelfp action)
(and (functionp action)
(fboundp action)))
"gray80"
"gray60")))))
......@@ -4318,6 +4325,8 @@ See sidebar for more commands to try.
(defclass property-sheet (dialog)
((orientation :initform :vertical)
(default-values :initform nil)
(methods :initform '(apply-properties restore-default-values cancel-properties))
(instance :initform nil :initarg :instance :accessor instance)
(properties :initform nil :initarg :properties :accessor properties)))
......@@ -4345,7 +4354,7 @@ See sidebar for more commands to try.
(draw-patch self x y (+ x width) (+ y height) :depressed nil :style :rounded)))
(defmethod initialize-instance :after ((sheet property-sheet) &key)
(with-slots (inputs properties instance) sheet
(with-slots (inputs properties instance default-values) sheet
(dolist (property properties)
(let ((row (make-sentence
(list
......@@ -4358,11 +4367,22 @@ See sidebar for more commands to try.
:read-only nil))
'property-row)))
;; (setf (no-background row) nil)
(push row inputs)))
(push row inputs)
(push (slot-value instance property) default-values)))
(setf default-values (nreverse default-values))
(setf inputs (nreverse inputs))
(update-parent-links sheet)
(freeze sheet)))
(defmethod restore-default-values ((sheet property-sheet))
(with-slots (inputs properties instance default-values) sheet
(let ((i inputs)
(d default-values))
(flet ((entry () (second (inputs (first i)))))
(dolist (property properties)
(set-value (entry) (pop d))
(pop i))))))
(defmethod layout :after ((sheet property-sheet))
(assert (every #'(lambda (d) (= 2 (length (inputs d)))) (inputs sheet))))
......@@ -4375,12 +4395,18 @@ See sidebar for more commands to try.
(defmethod get-property-list ((sheet property-sheet))
(mapcar #'evaluate (get-property-entries sheet)))
(defmethod apply-properties ((sheet property-sheet) instance)
(let ((plist (get-property-list sheet)))
(defmethod apply-properties ((sheet property-sheet) &optional instance)
(let ((plist (get-property-list sheet))
(i (or instance (instance sheet))))
(loop while plist do
(let* ((slot (pop plist))
(value (pop plist)))
(setf (slot-value instance slot) value)))))
(setf (slot-value i slot) value)))))
(defmethod cancel-properties ((sheet property-sheet))
(if (parent sheet)
(destroy (parent sheet))
(destroy sheet)))
(defmethod evaluate ((sheet property-sheet))
(prog1 nil (apply-properties sheet (instance sheet))))
......
......@@ -1901,7 +1901,10 @@ above.
(defmethod pick ((self halo))
(pick (slot-value self 'target)))
(defmethod tap ((self halo) x y) nil)
(defmethod tap ((self halo) x y)
(toggle-halo (slot-value self 'target)))
(defmethod make-halo ((self halo)) nil)
(defmethod scroll-tap ((self halo) x y)
(toggle-halo (slot-value self 'target)))
......@@ -2292,12 +2295,12 @@ above.
;; fixme
(defmethod draw :after ((self buffer))
(when *notification*
(draw *notification*))
(when *menubar*
(draw *menubar*))
(when *shell*
(draw *shell*)))
(draw *shell*))
(when *notification*
(draw *notification*)))
(defmethod tap ((self prompt) mouse-x mouse-y)
(declare (ignore mouse-y))
......@@ -3809,14 +3812,14 @@ supported compiler.
(dolist (line lines)
(callf max width (dash 4 (font-text-width line font)))))))
(defmethod notify-style ((self text) &optional (timeout (seconds->frames 10.0)))
(defmethod notify-style ((self text) &optional (timeout (seconds->frames 5.5)))
(setf (slot-value self 'timeout) timeout)
(setf (slot-value self 'category) :system)
(setf (foreground-color self) "black")
(setf (background-color self) "cornsilk")
(layout self)
(move-to self (+ (window-x) 8)
(+ (window-y) 35)))
(move-to self (+ (window-pointer-x) 12)
(- (window-pointer-y) 20)))
(defun recent-messages (&optional (n 5))
(nreverse (subseq *message-history* 0
......@@ -3829,7 +3832,8 @@ supported compiler.
(when *notification*
(remove-object (current-buffer) *notification*)
(setf *notification* notification))
(add-node (current-buffer) notification)))
(add-node (current-buffer) notification)
(bring-to-front notification)))
(defun notify-message-maybe ()
(when *use-notifications*
......@@ -3837,6 +3841,7 @@ supported compiler.
(defun notify (text)
(mapcar #'message (split-string-on-lines text))
(show-status text)
(notify-message text))
(add-hook '*message-hook* #'notify-message-maybe)
......@@ -4148,11 +4153,11 @@ supported compiler.
(defvar *menu-prototype* nil)
(defun make-menu (items &key target)
(defun make-menu (items &key target (class 'menu))
(make-tree items
:target target
:category :menu
:tree-class 'menu))
:tree-class class))
;; menu items should not accept any dragged widgets.
(defmethod accept ((self menu) arg) nil)
......@@ -4244,7 +4249,9 @@ supported compiler.
text
(if (or (functionp action)
(null action)
(fboundp action))
(xelfp action)
(and (functionp action)
(fboundp action)))
"gray80"
"gray60")))))
......@@ -4352,9 +4359,9 @@ supported compiler.
(:key #'identity :test 'equal :validator #'identity)
(format nil "X:~S Y:~S" x y))
(defun-memo modeline-database-string (local global)
(defun-memo modeline-database-string (selected local global)
(:key #'identity :test 'equal :validator #'identity)
(format nil "~S/~S objects" local global))
(format nil "~S objects selected from ~S/~S objects" selected local global))
(define-visual-macro modeline
(:super phrase
......@@ -4372,7 +4379,9 @@ supported compiler.
(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 objects (modeline-database-string (hash-table-count (slot-value (current-buffer) 'objects))
(set-value objects (modeline-database-string
(length (selection))
(hash-table-count (slot-value (current-buffer) 'objects))
(hash-table-count *database*)))
(set-value position
(modeline-position-string
......@@ -4738,6 +4747,8 @@ supported compiler.
(defclass property-sheet (dialog)
((orientation :initform :vertical)
(default-values :initform nil)
(methods :initform '(apply-properties restore-default-values cancel-properties))
(instance :initform nil :initarg :instance :accessor instance)
(properties :initform nil :initarg :properties :accessor properties)))
......@@ -4765,7 +4776,7 @@ supported compiler.
(draw-patch self x y (+ x width) (+ y height) :depressed nil :style :rounded)))
(defmethod initialize-instance :after ((sheet property-sheet) &key)
(with-slots (inputs properties instance) sheet
(with-slots (inputs properties instance default-values) sheet
(dolist (property properties)
(let ((row (make-sentence
(list
......@@ -4778,11 +4789,22 @@ supported compiler.
:read-only nil))
'property-row)))
;; (setf (no-background row) nil)
(push row inputs)))
(push row inputs)
(push (slot-value instance property) default-values)))
(setf default-values (nreverse default-values))
(setf inputs (nreverse inputs))
(update-parent-links sheet)
(freeze sheet)))
(defmethod restore-default-values ((sheet property-sheet))
(with-slots (inputs properties instance default-values) sheet
(let ((i inputs)
(d default-values))
(flet ((entry () (second (inputs (first i)))))
(dolist (property properties)
(set-value (entry) (pop d))
(pop i))))))
(defmethod layout :after ((sheet property-sheet))
(assert (every #'(lambda (d) (= 2 (length (inputs d)))) (inputs sheet))))
......@@ -4795,12 +4817,18 @@ supported compiler.
(defmethod get-property-list ((sheet property-sheet))
(mapcar #'evaluate (get-property-entries sheet)))
(defmethod apply-properties ((sheet property-sheet) instance)
(let ((plist (get-property-list sheet)))
(defmethod apply-properties ((sheet property-sheet) &optional instance)
(let ((plist (get-property-list sheet))
(i (or instance (instance sheet))))
(loop while plist do
(let* ((slot (pop plist))
(value (pop plist)))
(setf (slot-value instance slot) value)))))
(setf (slot-value i slot) value)))))
(defmethod cancel-properties ((sheet property-sheet))
(if (parent sheet)
(destroy (parent sheet))
(destroy sheet)))
(defmethod evaluate ((sheet property-sheet))
(prog1 nil (apply-properties sheet (instance sheet))))
......@@ -4829,6 +4857,7 @@ supported compiler.
(let ((frame (make-frame title dialog)))
(add-node (current-buffer) frame)
(center frame)
(align-to-pixels frame)
(freeze dialog)
(mapc #'freeze (inputs dialog))
nil))
......@@ -4929,10 +4958,13 @@ supported compiler.
(buffer-name width height z-sort-p background-image background-color
window-scrolling-speed horizontal-scrolling-margin vertical-scrolling-margin))
(defmethod apply-properties :after ((dialog buffer-properties-dialog) buffer)
(defmethod apply-properties :after ((dialog buffer-properties-dialog) &optional buffer)
(notify (format nil "Applied buffer properties to ~S." buffer))
(let ((buffer (or buffer (current-buffer))))
(with-slots (height width buffer-name) buffer
(resize buffer width height)
(rename-buffer buffer buffer-name)))
(rename-buffer buffer buffer-name))))
#+end_src
** Menu bar structure
......@@ -5236,6 +5268,11 @@ supported compiler.
(defmethod set-title ((self titlebar) title)
(set-value (input-node self :title) title))
(defmethod tap ((self titlebar) x y)
(let ((it (parent (parent self))))
(when it
(tap it x y))))
(define-visual-macro frame
(:super phrase
:slots ((frozen :initform t)
......@@ -5277,6 +5314,9 @@ supported compiler.
(defmethod evaluate ((frame frame))
(evaluate (second (inputs frame))))
(defmethod context-menu ((frame frame))
(context-menu (second (inputs frame))))
;; (defmethod as-drag ((self menu) x y)
;; (make-menu-frame self))
#+end_src
......@@ -5285,29 +5325,32 @@ supported compiler.
#+begin_src lisp :tangle commands.lisp
(defmethod make-method-menu-item ((self node) method target)
(assert (and target (keywordp method)))
(assert (and target method (symbolp method)))
(let ((method-string (pretty-string method)))
(list :label method-string
:pinned t
:locked t
:method method
:target target
:action (new 'task method target))))
:target (find-object target)
:action (make-instance 'task :method-name method :target (find-object target)))))
(defclass context-menu (menu)
((no-background :initform nil)))
(defmethod context-menu ((self node))
(let ((methods (slot-value self 'methods)))
(let (inputs)
(dolist (method (sort methods #'string<))
(push (make-method-menu-item self method (uuid self)) inputs))
(make-menu (list
;; :label
;; (string-downcase
;; (concatenate 'string
;; (get-some-object-name self)
;; " " (object-address-string self)))
:inputs (nreverse inputs)
(flet ((menu-item (args)
(make-menu args :target self)))
(let ((menu (make-instance 'context-menu
:inputs (mapcar #'menu-item (nreverse inputs))
:pinned nil
:expanded t
:locked t)
:target (find-uuid self)))))
:locked t)))
(prog1 menu
(bring-to-front menu)))))))
#+end_src
......
......@@ -74,9 +74,9 @@
(:key #'identity :test 'equal :validator #'identity)
(format nil "X:~S Y:~S" x y))
(defun-memo modeline-database-string (local global)
(defun-memo modeline-database-string (selected local global)
(:key #'identity :test 'equal :validator #'identity)
(format nil "~S/~S objects" local global))
(format nil "~S objects selected from ~S/~S objects" selected local global))
(define-visual-macro modeline
(:super phrase
......@@ -94,7 +94,9 @@
(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 objects (modeline-database-string (hash-table-count (slot-value (current-buffer) 'objects))
(set-value objects (modeline-database-string
(length (selection))
(hash-table-count (slot-value (current-buffer) 'objects))
(hash-table-count *database*)))
(set-value position
(modeline-position-string
......
* Task list
** TODO fix dialog boxes
*** TODO [#A] fix menu clicks sometimes not working
**** TODO [#A] TAP MENUBAR should forward click to menu
*** TODO [#A] context-menu with reset-to-current-values
**** TODO [#A] pin down context menu elements
**** TODO [#A] fix broken layout/rendering of context menu
*** TODO [#A] show error bubble and restore value when input incorrect
*** TODO [#A] fix halos not being in front
*** TODO [#B] don't allow halo on properties dialog
*** TODO [#B] fix click in text doesn't go to correct column
*** TODO [#B] ENTER should update value in property field
*** TODO [#C] fix halos not always being in front
*** TODO [#C] don't allow halo on properties dialog
*** TODO [#C] ENTER should update value in property field
*** TODO [#C] Adjust highlight draw in top right corner of rounded patch
*** TODO [#C] fix menubar not drawing over dialogs
*** TODO [#C] fix clicking away from menubar doesn't close menus or allow focusing
*** TODO [#C] add nice Apply/Cancel buttons
** TODO make master system menu todo list
*** TODO save-changes
......@@ -705,3 +709,33 @@
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#B] fix click in text doesn't go to correct column
CLOSED: [2017-04-20 Thu 07:30]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-20 Thu 08:38
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/fix dialog boxes
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#C] fix clicking away from menubar doesn't close menus or allow focusing
CLOSED: [2017-04-20 Thu 07:30]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-20 Thu 08:38
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/fix dialog boxes
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#A] make context-menu on frame go to contents
CLOSED: [2017-04-20 Thu 08:37]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-20 Thu 08:38
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/fix dialog boxes
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
......@@ -54,5 +54,12 @@
(trace xelf::do-show-buffer-properties-dialog)
(trace xelf::show-buffer-properties-dialog)
(trace xelf::close-menus)
(trace xelf::context-menu)
(trace xelf::restore-default-values)
(trace xelf::make-menu)
(trace xelf::make-tree)
(trace xelf::make-halo)
(trace xelf::make-method-menu-item)
(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