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

fix data entry widget.

parent 61e5ae3e
......@@ -431,12 +431,12 @@ See sidebar for more commands to try.
(define-handle copy :copy)
(defmethod tap ((self copy) x y)
(copy (current-buffer) (cons (slot-value self 'target) (get-selection (current-buffer)))))
(copy (current-buffer)))
(define-handle cut :cut)
(defmethod tap ((self cut) x y)
(cut (current-buffer) (cons (slot-value self 'target) (get-selection (current-buffer)))))
(cut (current-buffer)))
;;; The halo, which manages all the handles
......@@ -572,7 +572,7 @@ See sidebar for more commands to try.
(defclass prompt (node)
((font :initform *prompt-font*)
(read-only :initform nil)
(read-only :initform nil :accessor read-only :initarg :read-only)
(point :initform 0 :documentation "Integer index of cursor within prompt line.")
(line :initform "" :documentation "Currently edited command line.")
(last-line :initform nil)
......@@ -666,33 +666,35 @@ See sidebar for more commands to try.
;; (when (plusp (length line)) (queue line (slot-value self 'history)))
(defmethod enter ((self prompt) &optional no-clear)
(labels ((print-it (c)
(message "~A" c)))
(with-slots (line result history error-output) self
(with-slots (line result history error-output) self
(let* ((*read-eval* nil)
(sexp (read-expression self line))
(line* line))
(unless no-clear (clear-line self))
(setf error-output
(with-output-to-string (*standard-output*)
(when sexp
(if *debug-on-error*
(evaluate-expression self sexp)
(handler-case
(handler-bind (((not serious-condition)
(lambda (c)
(print-it c)
;; If there's a muffle-warning
;; restart associated, use it to
;; avoid double-printing.
(let ((r (find-restart 'muffle-warning c)))
(when r (invoke-restart r))))))
(evaluate-expression self sexp))
(condition (c)
(print-it c)))))))
(if (zerop (length error-output))
(setf error-output nil)
(setf result nil))
(line* line)
(error-p nil))
(labels ((print-it (c)
(setf error-p t)
(message "~A" c)))
;;(unless no-clear (clear-line self))
(setf error-output
(with-output-to-string (*standard-output*)
(when sexp
(if *debug-on-error*
(evaluate-expression self sexp)
(handler-case
(handler-bind (((not serious-condition)
(lambda (c)
(print-it c)
;; If there's a muffle-warning
;; restart associated, use it to
;; avoid double-printing.
(let ((r (find-restart 'muffle-warning c)))
(when r (invoke-restart r))))))
(evaluate-expression self sexp))
(condition (c)
(print-it c)))))))
(if (not error-p)
(setf error-output nil)
(setf result nil))
(when (plusp (length line*))
(queue line* history))))))
......@@ -1356,6 +1358,7 @@ See sidebar for more commands to try.
(setf y (+ (- center-y (/ width 2))))))))
(defmethod center-as-dialog ((self node))
(layout self)
(center self)
(align-to-pixels self))
......@@ -1479,8 +1482,12 @@ See sidebar for more commands to try.
(frozen :initform nil)
(orientation :initform :vertical)
(operation :initform :empty-phrase)
(result :initform nil)
(category :initform :structure)))
(defmethod update :after ((self phrase))
(layout self))
(defmethod evaluate ((self phrase))
(mapcar #'evaluate (slot-value self 'inputs)))
......@@ -1852,16 +1859,17 @@ See sidebar for more commands to try.
(defmethod evaluate-expression ((self entry) sexp)
(with-slots (value type-specifier parent) self
;;(assert (and (listp sexp) (= 1 (length sexp))))
(let ((sexp0 (if (listp sexp) sexp (list sexp))))
(let ((sexp0 (if (and (listp sexp) (= 1 (length sexp)))
sexp
(list sexp))))
(let ((datum (first sexp0)))
(if (or (null type-specifier)
(type-check self datum))
(setf value datum)
(progn (setf value datum) (message "Set datum ~A" datum))
(message "Warning: value entered does not match type ~S. Not storing value."
type-specifier))
(when parent (child-updated parent self))))))
(defmethod enter ((self entry) &optional no-clear)
(unless (slot-value self 'read-only)
(call-next-method self no-clear)))
......
......@@ -651,7 +651,7 @@ above.
(defclass prompt (node)
((font :initform *prompt-font*)
(read-only :initform nil)
(read-only :initform nil :accessor read-only :initarg :read-only)
(point :initform 0 :documentation "Integer index of cursor within prompt line.")
(line :initform "" :documentation "Currently edited command line.")
(last-line :initform nil)
......@@ -745,33 +745,35 @@ above.
;; (when (plusp (length line)) (queue line (slot-value self 'history)))
(defmethod enter ((self prompt) &optional no-clear)
(labels ((print-it (c)
(message "~A" c)))
(with-slots (line result history error-output) self
(with-slots (line result history error-output) self
(let* ((*read-eval* nil)
(sexp (read-expression self line))
(line* line))
(unless no-clear (clear-line self))
(setf error-output
(with-output-to-string (*standard-output*)
(when sexp
(if *debug-on-error*
(evaluate-expression self sexp)
(handler-case
(handler-bind (((not serious-condition)
(lambda (c)
(print-it c)
;; If there's a muffle-warning
;; restart associated, use it to
;; avoid double-printing.
(let ((r (find-restart 'muffle-warning c)))
(when r (invoke-restart r))))))
(evaluate-expression self sexp))
(condition (c)
(print-it c)))))))
(if (zerop (length error-output))
(setf error-output nil)
(setf result nil))
(line* line)
(error-p nil))
(labels ((print-it (c)
(setf error-p t)
(message "~A" c)))
;;(unless no-clear (clear-line self))
(setf error-output
(with-output-to-string (*standard-output*)
(when sexp
(if *debug-on-error*
(evaluate-expression self sexp)
(handler-case
(handler-bind (((not serious-condition)
(lambda (c)
(print-it c)
;; If there's a muffle-warning
;; restart associated, use it to
;; avoid double-printing.
(let ((r (find-restart 'muffle-warning c)))
(when r (invoke-restart r))))))
(evaluate-expression self sexp))
(condition (c)
(print-it c)))))))
(if (not error-p)
(setf error-output nil)
(setf result nil))
(when (plusp (length line*))
(queue line* history))))))
......@@ -1449,6 +1451,7 @@ hybrid GUI inspired by MIT Scratch and its derivatives.
(setf y (+ (- center-y (/ width 2))))))))
(defmethod center-as-dialog ((self node))
(layout self)
(center self)
(align-to-pixels self))
......@@ -1582,8 +1585,12 @@ hybrid GUI inspired by MIT Scratch and its derivatives.
(frozen :initform nil)
(orientation :initform :vertical)
(operation :initform :empty-phrase)
(result :initform nil)
(category :initform :structure)))
(defmethod update :after ((self phrase))
(layout self))
(defmethod evaluate ((self phrase))
(mapcar #'evaluate (slot-value self 'inputs)))
......@@ -1987,16 +1994,17 @@ hybrid GUI inspired by MIT Scratch and its derivatives.
(defmethod evaluate-expression ((self entry) sexp)
(with-slots (value type-specifier parent) self
;;(assert (and (listp sexp) (= 1 (length sexp))))
(let ((sexp0 (if (listp sexp) sexp (list sexp))))
(let ((sexp0 (if (and (listp sexp) (= 1 (length sexp)))
sexp
(list sexp))))
(let ((datum (first sexp0)))
(if (or (null type-specifier)
(type-check self datum))
(setf value datum)
(progn (setf value datum) (message "Set datum ~A" datum))
(message "Warning: value entered does not match type ~S. Not storing value."
type-specifier))
(when parent (child-updated parent self))))))
(defmethod enter ((self entry) &optional no-clear)
(unless (slot-value self 'read-only)
(call-next-method self no-clear)))
......
* Task list
** TODO [#A] fix data entry widget
** TODO [#A] context-menus
** TODO [#A] fix data entry widget validation
** TODO [#A] create buffer switch menu
** TODO [#A] command undo/redo
** TODO [#A] context-menus
** TODO [#A] fix command dialogs
** TODO [#A] fix can't drag item out of shell
** TODO [#A] command undo/redo
** TODO [#A] scrolling the buffer window
** TODO [#B] fix disappearing shell prompt
** TODO [#B] hand me a tile / reference
** TODO [#B] save-buffer
** TODO [#B] load-buffer
......
......@@ -25,6 +25,7 @@
;; start the buffer running
(switch-to-buffer plong)
(at-next-update
(add-node (current-buffer) (make-instance 'xelf::resize-buffer) 200 200)
(add-node (current-buffer)
(xelf::open-frame
"Buffers"
......
......@@ -4283,6 +4283,7 @@ Returns a newly allocated list."
(needs-layout :initform t :accessor needs-layout)
(caption :initform nil)
(tasks :initform nil)
(read-only :initform nil :accessor read-only :initarg :read-only)
(image :initform nil :accessor image :initarg :image :documentation "Name of texture to be displayed, if any.")))
(defmethod bring-to-front ((self node))
......
......@@ -5218,6 +5218,7 @@ subclasses.)
(needs-layout :initform t :accessor needs-layout)
(caption :initform nil)
(tasks :initform nil)
(read-only :initform nil :accessor read-only :initarg :read-only)
(image :initform nil :accessor image :initarg :image :documentation "Name of texture to be displayed, if any.")))
#+end_src
......
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