Commit 11c6765f authored by Troels Henriksen's avatar Troels Henriksen
Browse files

Added hackish implementation of typeout overlays. They are used for

symbol-completion in Lisp syntax and not really anything else.

They're also not keyboard-sensitive or anything. I plan on making them
appear like an actual window to Climacs, so they fit in with the
command loop, though they'll still be highly ephemeral. They are not
to be used to display information that should stay alive during an
editing session.
parent 16697bfa
......@@ -207,7 +207,7 @@ Each newline and following whitespace is replaced by a single space."
(def-print-for-menu note-compiler-note "Note" +brown+)
(defun show-notes (notes view-name definition)
(climacs-gui:with-typeout (stream (format nil "Compiler Notes: ~A ~A" view-name definition))
(climacs-gui:with-typeout-view (stream (format nil "Compiler Notes: ~A ~A" view-name definition))
(loop for note in notes
do (with-output-as-presentation (stream note 'compiler-note)
(print-for-menu note stream))
......@@ -422,7 +422,7 @@ macros or similar). If no such form can be found, return NIL."
(with-drawing-options (stream :ink +dark-blue+
:text-style (make-text-style :fixed nil nil))
(princ (dspec item) stream))))
(climacs-gui:with-typeout (stream (format nil "~A ~A" type symbol))
(climacs-gui:with-typeout-view (stream (format nil "~A ~A" type symbol))
(loop for xref in xrefs
do (with-output-as-presentation (stream xref 'xref)
(printer xref stream))
......@@ -270,20 +270,22 @@ window"))
(setf (windows *application-frame*) (list climacs-pane)
(views *application-frame*) (list (view climacs-pane)))
(vertically ()
(if *with-scrollbars*
(scrolling ()
(if *with-scrollbars*
(scrolling ()
(minibuffer (make-pane 'climacs-minibuffer-pane)))
(vertically (:scroll-bars nil)
(overlaying ()
(vertically (:scroll-bars nil)
(:top-level ((lambda (frame)
(let ((*kill-ring* (kill-ring frame)))
(esa-top-level frame :prompt "M-x "))))))
(with-frame-manager ((make-instance 'climacs-frame-manager))
(esa-top-level frame :prompt "M-x ")))))))
(define-esa-top-level ((frame climacs) command-parser
......@@ -693,5 +695,5 @@ pane to a clone of the view in `orig-pane', provided that
;;; For the ESA help functions.
(defmethod invoke-with-help-stream ((frame climacs) title continuation)
(with-typeout (stream title)
(with-typeout-view (stream title)
(funcall continuation stream)))
......@@ -87,6 +87,7 @@
;; Typeout
#:typeout-view #:typeout-view-p
#:with-typeout-view #:invoke-with-typeout-view
#:with-typeout #:invoke-with-typeout))
(defpackage :climacs-core
;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*-
;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
;;; (c) copyright 2008 by
;;; Troels Henriksen (
......@@ -18,10 +18,18 @@
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
;;; Typeout pane support.
;;; Typeout is the word for "output whatever". It's a facility for
;;; drawing stuff that doesn't go in a buffer. There are two kinds of
;;; typeout: typeout views, that act like uneditable views, and
;;; typeout overlays, that are highly ephemeral and temporary
;;; creations to be used for short-lived interaction.
(in-package :climacs-gui)
;;; Typeout views.
(defclass typeout-view (drei-view textual-view)
((%output-history :accessor output-history
:initform (make-instance 'standard-tree-output-record)
......@@ -110,34 +118,34 @@ viewport, do nothing."
:name label)))
;; Because specialising on the type of `climacs' is so useful...
(defun invoke-with-typeout (climacs label continuation)
(defun invoke-with-typeout-view (climacs label continuation)
"Call `continuation' with a single argument, a
stream meant for typeout. `Climacs' is the Climacs instance in
which the typeout pane should be shown, and `label' is the name
of the created typeout view. Returns NIL."
(let* ((typeout-view (ensure-typeout-view climacs label))
(pane-with-typeout (or (find typeout-view (windows climacs)
(pane-with-typeout-view (or (find typeout-view (windows climacs)
:key #'view)
(let ((pane (split-window t)))
(setf (view pane) typeout-view)
(let ((new-record (with-output-to-output-record (pane-with-typeout)
(with-output-recording-options (pane-with-typeout :record t :draw t)
(let ((new-record (with-output-to-output-record (pane-with-typeout-view)
(with-output-recording-options (pane-with-typeout-view :record t :draw t)
(when (last-cursor-position typeout-view)
(setf (stream-cursor-position pane-with-typeout)
(setf (stream-cursor-position pane-with-typeout-view)
(values-list (last-cursor-position typeout-view))))
(funcall continuation pane-with-typeout)
(funcall continuation pane-with-typeout-view)
(setf (last-cursor-position typeout-view)
(multiple-value-list (stream-cursor-position pane-with-typeout)))))))
(multiple-value-list (stream-cursor-position pane-with-typeout-view)))))))
(add-output-record new-record (output-history typeout-view))
(setf (dirty typeout-view) t)
(defmacro with-typeout ((stream &optional (label "Typeout")) &body body)
(defmacro with-typeout-view ((stream &optional (label "Typeout")) &body body)
"Evaluate `body' with `stream' bound to a stream that can be
used for typeout. `Label' is the name of the created typeout
`(invoke-with-typeout *esa-instance* ,label
`(invoke-with-typeout-view *esa-instance* ,label
#'(lambda (,stream)
......@@ -157,48 +165,322 @@ manually by the user, the stream will recreate it the next time
output is performed."))
(defmethod stream-write-char ((stream typeout-stream) char)
(with-typeout (typeout (label stream))
(with-typeout-view (typeout (label stream))
(stream-write-char typeout char)))
(defmethod stream-line-column ((stream typeout-stream))
(with-typeout (typeout (label stream))
(with-typeout-view (typeout (label stream))
(stream-line-column typeout)))
(defmethod stream-start-line-p ((stream typeout-stream))
(with-typeout (typeout (label stream))
(with-typeout-view (typeout (label stream))
(stream-start-line-p typeout)))
(defmethod stream-write-string ((stream typeout-stream) string &optional (start 0) end)
(with-typeout (typeout (label stream))
(with-typeout-view (typeout (label stream))
(stream-write-string typeout string start end)))
(defmethod stream-terpri ((stream typeout-stream))
(with-typeout (typeout (label stream))
(with-typeout-view (typeout (label stream))
(stream-terpri typeout)))
(defmethod stream-fresh-line ((stream typeout-stream))
(with-typeout (typeout (label stream))
(with-typeout-view (typeout (label stream))
(stream-fresh-line typeout)))
(defmethod stream-finish-output ((stream typeout-stream))
(with-typeout (typeout (label stream))
(with-typeout-view (typeout (label stream))
(stream-finish-output typeout)))
(defmethod stream-force-output ((stream typeout-stream))
(with-typeout (typeout (label stream))
(with-typeout-view (typeout (label stream))
(stream-force-output typeout)))
(defmethod stream-clear-output ((stream typeout-stream))
(with-typeout (typeout (label stream))
(with-typeout-view (typeout (label stream))
(stream-clear-output typeout)))
(defmethod stream-advance-to-column ((stream typeout-stream) (column integer))
(with-typeout (typeout (label stream))
(with-typeout-view (typeout (label stream))
(stream-advance-to-column typeout column)))
(defmethod interactive-stream-p ((stream typeout-stream))
(with-typeout (typeout (label stream))
(with-typeout-view (typeout (label stream))
(interactive-stream-p typeout)))
(defun make-typeout-stream (climacs label)
(make-instance 'typeout-stream :climacs climacs :label label))
;;; Typeout overlays.
(defclass overlaying-pane (bboard-pane)
((%overlay-pane :accessor overlay-pane
:initform nil
:type (or null pane)
:documentation "The overlay pane. When this is
set, the overlay tree will be updated.")
(%overlay-tree :accessor overlay-tree
:initform nil
:type (or null pane)
:documentation "The pane hierarchy containing
the overlay pane. Should not be changed manually, will be updated
when the overlay-pane is set.")
(%content-pane :reader content-pane
:initform (error "A content-pane must be provided")
:type pane
:initarg :contents
:documentation "The pane containing the usually
displayed contents."))
(:documentation "This layout pane facilitates the addition and
removal of an overlay pane positioned at the top of the
`overlaying-pane' that will obscure the contents. For ease of
use, the overlay-pane and the pane hierarchy containing this pane
are handled seperately."))
(defun find-topmost-parent (sheet)
"Find the topmost parent of `sheet', that is the parent of
`sheet' (or `sheet' itself) that does not have a sheet parent or
has a graft parent."
(if (or (not (sheetp (sheet-parent sheet)))
(typep (sheet-parent sheet) 'graft))
(find-topmost-parent (sheet-parent sheet))))
(defmethod (setf overlay-pane) :before (new-overlay (pane overlaying-pane))
(when (overlay-pane pane)
(sheet-disown-child pane (overlay-tree pane))
(setf (overlay-tree pane) nil)))
(defmethod (setf overlay-pane) :after (new-overlay (pane overlaying-pane))
(when new-overlay
(let ((topmost-parent (find-topmost-parent new-overlay)))
(sheet-adopt-child pane topmost-parent)
(setf (overlay-tree pane) topmost-parent))))
(defmethod initialize-instance :after ((object overlaying-pane) &rest args
&key overlay)
(declare (ignore args))
(when overlay
(setf (overlay-pane object) overlay))
(sheet-adopt-child object (content-pane object)))
(defmethod allocate-space ((pane overlaying-pane) width height)
(allocate-space (content-pane pane) width height)
(with-accessors ((overlay overlay-tree)) pane
(when overlay
(move-sheet overlay 0 0)
overlay width (space-requirement-height (compose-space overlay))))))
(defmethod compose-space ((pane overlaying-pane) &rest args)
(apply #'compose-space (content-pane pane) args))
(defmacro overlaying ((&rest options) &body contents)
"Create an overlaying pane with `contents' arranged vertically
as the contents of the overlaying pane. There will be no initial
`(make-pane 'overlaying-pane ,@options :contents (vertically () ,@contents)))
(defun pane-overlayer (pane)
"Return the `overlaying-pane' that contains `pane'"
(if (typep pane 'overlaying-pane)
(unless (null (sheet-parent pane))
(pane-overlayer (sheet-parent pane)))))
(defun add-typeout (&optional (pane (current-window)))
"Return the typeout overlay of `pane', creating one if it
doesn't exist."
((frame-manager (pane-frame pane)) (pane-frame pane))
(let ((overlayer (pane-overlayer pane)))
(or (overlay-pane overlayer)
(let ((overlay (make-pane 'typeout-overlay
:width (bounding-rectangle-width
(sheet-region overlayer)))))
(outlining () overlay) ; This adds an outlining-pane as
; the parent of `overlay'.
(setf (overlay-pane overlayer) overlay))))))
(defun remove-typeout (&optional (pane (current-window)))
"Remove the typeout overlay of `pane', defaulting to the
current window."
(setf (overlay-pane (pane-overlayer pane)) nil))
(defclass typeout-overlay (clim-stream-pane)
(:default-initargs :background +cornsilk1+
:scroll-bars nil))
(defun invoke-with-typeout (pane continuation &key erase)
"Invoke `continuation' with a single argument - a typeout
overlay for `pane'. If `erase' is true, the typeout overlay will
be newly created, and any old overlay will have been deleted."
(with-look-and-feel-realization ((frame-manager (pane-frame pane)) (pane-frame pane))
(when erase (remove-typeout pane))
(let* ((typeout (add-typeout pane)))
;; Expand the typeout to the proper width...
(change-space-requirements typeout)
(let ((values (multiple-value-list
(funcall continuation typeout))))
(remove-typeout pane)
(values-list values)))))
(defmacro with-typeout ((stream &rest args &key erase (window (current-window)))
&body body)
"Evaluate `body' with `stream' bound to a typeout overlay for
`window'. If `erase' is true, the typeout overlay will be newly
created, and any old overlay will have been deleted."
(declare (ignore erase))
(with-keywords-removed (args (:window))
`(invoke-with-typeout ,window
#'(lambda (,stream)
;;; A frame manager for using typeout when appropriate.
(defclass climacs-frame-manager (frame-manager)
:reader standard-frame-manager
:initform (find-frame-manager)
:type frame-manager
:documentation "The frame manager that this
`climacs-frame-manager' dispatches functions to."
:initarg :standard-frame-manager))
(:documentation "This class thinly wraps another frame manager
instance and delegates most frame managing to this other
manager. It is used to implement Climacs \"look and feel\" where
;;; A simple dispatching implementation of the frame manager protocol.
(defmacro define-dispatching-fun (name (frame-manager-arg &rest args))
"Defines a dispatching function for the frame manager protocol
for `climacs-frame-manager'. Will assume that `frame-manager-arg'
is the frame manager."
`(defmethod ,name ((,frame-manager-arg climacs-frame-manager) ,@args)
(when (standard-frame-manager ,frame-manager-arg)
(,name (standard-frame-manager ,frame-manager-arg) ,@args))))
(define-dispatching-fun frame-manager-frames (frame-manager))
(define-dispatching-fun adopt-frame (frame-manager frame))
(define-dispatching-fun disown-frame (frame-manager frame))
(define-dispatching-fun port (frame-manager))
(define-dispatching-fun note-frame-enabled (frame-manager frame))
(define-dispatching-fun note-frame-disabled (frame-manager frame))
(define-dispatching-fun note-frame-iconified (frame-manager frame))
(define-dispatching-fun note-frame-deiconified (frame-manager frame))
(define-dispatching-fun note-command-enabled (frame-manager frame command-name))
(define-dispatching-fun note-command-disabled (frame-manager frame command-name))
(defmethod frame-manager-notify-user ((frame-manager climacs-frame-manager) message &rest args)
(apply #'frame-manager-notify-user frame-manager message args))
(define-dispatching-fun generate-panes (frame-manager frame))
(define-dispatching-fun find-pane-for-frame (frame-manager frame))
;;; Now for the look & feel.
(defun menu-item-option (menu-item option &optional default)
(if (listp menu-item)
(getf (menu-item-options menu-item) option default)
(define-presentation-type typeout-menu-item ())
(defmethod menu-choose-from-drawer
((menu typeout-overlay) presentation-type drawer
&key x-position y-position cache unique-id id-test cache-value cache-test
default-presentation pointer-documentation)
(declare (ignore cache unique-id
id-test cache-value cache-test default-presentation
x-position y-position))
(with-room-for-graphics (menu :first-quadrant nil)
(funcall drawer menu presentation-type))
(let ((*pointer-documentation-output* pointer-documentation))
(with-input-context (`(or ,presentation-type blank-area) :override t)
(object type event)
(prog1 nil (loop for gesture = (read-gesture :stream menu :peek-p t)
until (or (and (typep gesture 'keyboard-event)
(keyboard-event-character gesture))
(characterp gesture))
do (read-gesture :stream menu)))
(blank-area nil)
(t (values object event)))
(abort-gesture () nil))))
(defmethod frame-manager-menu-choose
((frame-manager climacs-frame-manager) items
&rest options
&key (associated-window (current-window)) printer presentation-type
(default-item nil default-item-p)
text-style label cache unique-id id-test cache-value cache-test
max-width max-height n-rows n-columns x-spacing y-spacing row-wise
cell-align-x cell-align-y (scroll-bars :vertical)
;; We provide pointer documentation by default.
(pointer-documentation *pointer-documentation-output*))
(flet ((drawer (overlay type)
(let* ((height (bounding-rectangle-height
(with-new-output-record (overlay)
(when label
(with-text-style (overlay (make-text-style :serif :italic :large))
(write-string label overlay)
(terpri overlay)))
(draw-standard-menu overlay type items
(if default-item-p
(first items))
:item-printer (or printer
:max-width max-width
:max-height max-height
:n-rows n-rows
:n-columns n-columns
:x-spacing x-spacing
:y-spacing y-spacing
:row-wise row-wise
:cell-align-x cell-align-x
:cell-align-y cell-align-y))))
(overlayer (pane-overlayer overlay))
(overlay-tree (overlay-tree overlayer)))
;; Tell it how big it is.
(change-space-requirements overlay :height height)
;; Bigger than the available space? User OK with ugly?
;; Then add scrolling.
(when (and (> height (bounding-rectangle-height overlayer))
(not (typep overlay-tree 'scroller-pane)))
(setf (overlay-pane overlayer) nil ; To clear the parent/child relationship
(overlay-pane overlayer)
(prog1 overlay
(scrolling (:scroll-bars scroll-bars) ; Now re-add with scroll-bars.
;; The overlayer has default space requirements now,
;; make it reevaluate its life.
(change-space-requirements overlayer)))))
(multiple-value-bind (object event)
(with-typeout (menu :erase t :window associated-window)
(when text-style
(setf (medium-text-style menu) text-style))
(letf (((stream-default-view menu) +textual-menu-view+))
(menu-choose-from-drawer menu (or presentation-type 'typeout-menu-item)
:cache cache
:unique-id unique-id
:id-test id-test
:cache-value cache-value
:cache-test cache-test
:pointer-documentation pointer-documentation)))
(unless (null event) ; Event is NIL if user aborted.
(let ((subitems (menu-item-option object :items 'menu-item-no-items)))
(if (eq subitems 'menu-item-no-items)
(values (menu-item-value object) object event)
(apply #'frame-manager-menu-choose
frame-manager subitems
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