Commit 97246b4b authored by Troels Henriksen's avatar Troels Henriksen
Browse files

Revamped typeout panes and turned them into typeout views.

Stability not guaranteed, the code is... special.

Some things are still known to be suboptimal.
parent 7771706a
......@@ -207,15 +207,14 @@ 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)
(let ((stream (climacs-gui:typeout-window
(format nil "~10TCompiler Notes: ~A ~A" view-name definition))))
(climacs-gui:with-typeout (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))
(terpri stream)
count note into length
finally (change-space-requirements stream
:height (* length (stream-line-height stream)))
:height (* length (stream-line-height stream)))
(scroll-extent stream 0 0))))
(defgeneric goto-location (location))
......@@ -351,9 +350,10 @@ Each newline and following whitespace is replaced by a single space."
function (explicitly via `flet' or `labels', does not expand
macros or similar). If no such form can be found, return NIL."
(labels ((locally-binding-p (form)
(find-if #'(lambda (symbol)
(form-equal syntax (form-operator form) (string symbol)))
*local-function-definers*))
(when (form-operator form)
(find-if #'(lambda (symbol)
(form-equal syntax (form-operator form) (string symbol)))
*local-function-definers*)))
(match (form-operator)
(when form-operator
(form-equal syntax form-operator symbol-form)))
......@@ -419,15 +419,14 @@ 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))))
(let ((stream (climacs-gui:typeout-window
(format nil "~10T~A ~A" type symbol))))
(climacs-gui:with-typeout (stream (format nil "~A ~A" type symbol))
(loop for xref in xrefs
do (with-output-as-presentation (stream xref 'xref)
(printer xref stream))
(terpri stream)
count xref into length
finally (change-space-requirements stream
:height (* length (stream-line-height stream)))
:height (* length (stream-line-height stream)))
(scroll-extent stream 0 0)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......
......@@ -44,7 +44,8 @@
(:file "c-syntax-commands" :depends-on ("c-syntax" "misc-commands"))
(:file "java-syntax" :depends-on ("core"))
(:file "java-syntax-commands" :depends-on ("java-syntax" "misc-commands"))
(:file "gui" :depends-on ("packages"))
(:file "typeout" :depends-on ("packages"))
(:file "gui" :depends-on ("packages" "typeout"))
(:file "core" :depends-on ("gui"))
(:file "io" :depends-on ("packages" "gui"))
(:file "groups" :depends-on ("core"))
......
......@@ -56,13 +56,6 @@ displayed by a Drei instance."))
(defmethod switch-to-view ((drei climacs-pane) (view drei-view))
(setf (view drei) view))
(defmethod switch-to-view ((drei typeout-pane) (view drei-view))
(let ((usable-pane (or (find-if #'(lambda (pane)
(typep pane 'drei))
(windows *application-frame*))
(split-window t))))
(switch-to-view usable-pane view)))
(defmethod switch-to-view (pane (name string))
(let ((view (find name (views (pane-frame pane))
:key #'subscripted-name :test #'string=)))
......@@ -124,7 +117,8 @@ it will be replaced by some other view."))
;; view will be kept in the buffer, and the view will thus not be
;; garbage-collected. So create a circular reference structure
;; that can be garbage-collected instead.
(setf (buffer view) (dummy-buffer))
(when (buffer-view-p view)
(setf (buffer view) (dummy-buffer)))
(full-redisplay (current-window))
(current-view)))
......
......@@ -8,6 +8,8 @@
;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr)
;;; (c) copyright 2005 by
;;; Aleksandar Bakic (a_bakic@yahoo.com)
;;; (c) copyright 2006-2008 by
;;; Troels Henriksen (athas@sigkill.dk)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
......@@ -142,23 +144,6 @@ window"))
(with-accessors ((views views)) (pane-frame pane)
(full-redisplay pane)))
(defclass typeout-pane (application-pane esa-pane-mixin)
((%active :accessor active
:initform nil
:initarg :active)))
(defun typeout-pane-p (pane)
"Return true if `pane' is a typeout pane."
(typep pane 'typeout-pane))
(defmethod buffer ((pane typeout-pane)))
(defmethod point-of ((pane typeout-pane)))
(defmethod mark-of ((pane typeout-pane)))
(defmethod full-redisplay ((pane typeout-pane)))
(defgeneric buffer-pane-p (pane)
(:documentation "Returns T when a pane contains a buffer."))
......@@ -225,18 +210,6 @@ window"))
(make-command-table 'climacs-help-table :inherit-from '(help-table)
:errorp nil)
;;; We have a special command table for typeout panes because we want
;;; to keep being able to do window, buffer, etc, management, but we do
;;; not want any actual editing commands.
(make-command-table 'typeout-pane-table
:errorp nil
:inherit-from '(global-esa-table
base-table
pane-table
window-table
development-table
climacs-help-table))
(make-command-table 'global-climacs-table
:errorp nil
:inherit-from '(base-table
......@@ -448,6 +421,12 @@ displayed in any window. If necessary, clone a view on display."
(:documentation "Display interesting information about
`view' (which is in `master-pane') to `info-pane'."))
(defgeneric display-view-status-to-info-pane (info-pane master-pane view)
(:documentation "Display interesting information about the
status of `view' (which is in `master-pane') to `info-pane'. The
status should be things like whether it is modified, read-only,
etc."))
(defmethod display-view-info-to-info-pane ((info-pane climacs-info-pane)
(master-pane climacs-pane)
(view drei-syntax-view))
......@@ -487,23 +466,36 @@ displayed in any window. If necessary, clone a view on display."
"Isearch"))
(princ #\) info-pane)))
(defmethod display-view-info-to-info-pane ((info-pane climacs-info-pane)
(master-pane climacs-pane)
(view typeout-view)))
(defmethod display-view-status-to-info-pane ((info-pane climacs-info-pane)
(master-pane climacs-pane)
(view drei-syntax-view))
(with-output-as-presentation (info-pane view 'read-only)
(princ (cond
((read-only-p (buffer view)) "%")
((needs-saving (buffer view)) "*")
(t "-"))
info-pane))
(with-output-as-presentation (info-pane view 'modified)
(princ (cond
((needs-saving (buffer view)) "*")
((read-only-p (buffer view)) "%")
(t "-"))
info-pane))
(princ " " info-pane))
(defmethod display-view-status-to-info-pane ((info-pane climacs-info-pane)
(master-pane climacs-pane)
(view typeout-view)))
(defun display-info (frame pane)
(let* ((master-pane (master-pane pane))
(view (view master-pane)))
(princ " " pane)
(with-output-as-presentation (pane view 'read-only)
(princ (cond
((read-only-p (buffer view)) "%")
((needs-saving (buffer view)) "*")
(t "-"))
pane))
(with-output-as-presentation (pane view 'modified)
(princ (cond
((needs-saving (buffer view)) "*")
((read-only-p (buffer view)) "%")
(t "-"))
pane))
(princ " " pane)
(display-view-status-to-info-pane pane master-pane view)
(with-text-face (pane :bold)
(with-output-as-presentation (pane view 'view)
(format pane "~A" (subscripted-name view)))
......@@ -628,14 +620,10 @@ pane to a clone of the view in `orig-pane', provided that
`orig-pane' has a view."))
(defmethod setup-split-pane ((orig-pane climacs-pane) (new-pane climacs-pane) clone-view)
(setf (offset (point (buffer (view orig-pane)))) (offset (point (view orig-pane)))
(view new-pane) (if clone-view
(clone-view-for-climacs (pane-frame orig-pane) (view orig-pane))
(any-preferably-undisplayed-view))))
(defmethod setup-split-pane ((orig-pane typeout-pane) (new-pane climacs-pane) clone-view)
(when (buffer-view-p (view orig-pane))
(setf (offset (point (buffer (view orig-pane)))) (offset (point (view orig-pane)))))
(setf (view new-pane) (if clone-view
(any-undisplayed-view)
(clone-view-for-climacs (pane-frame orig-pane) (view orig-pane))
(any-preferably-undisplayed-view))))
(defun split-window (&optional (vertically-p nil) (clone-view nil) (pane (current-window)))
......@@ -652,35 +640,6 @@ pane to a clone of the view in `orig-pane', provided that
(activate-window pane)
new-pane))))
(defun make-typeout-constellation (&key label pane)
(let* ((typeout-pane
(or pane
(make-pane 'typeout-pane :foreground *foreground-color*
:background *background-color*
:width 900 :height 400 :display-time nil :name label)))
(label
(make-pane 'label-pane :label label))
(vbox
(vertically ()
(scrolling (:scroll-bar :vertical) typeout-pane) label)))
(values vbox typeout-pane)))
(defun typeout-window (&optional (label "Typeout") (pane (current-window)))
"Get a typeout pane labelled `label'. If a pane with this label
already exists, it will be returned. Otherwise, a new pane will
be created."
(with-look-and-feel-realization
((frame-manager *esa-instance*) *esa-instance*)
(or (find label (windows *esa-instance*) :key #'pane-name)
(multiple-value-bind (vbox new-pane) (make-typeout-constellation :label label)
(let* ((current-window pane)
(constellation-root (find-parent current-window)))
(push new-pane (windows *esa-instance*))
(other-window)
(replace-constellation constellation-root vbox t)
(full-redisplay current-window)
new-pane)))))
(defun delete-window (&optional (window (current-window)))
(unless (null (cdr (windows *esa-instance*)))
(let* ((constellation (find-parent window))
......@@ -719,99 +678,6 @@ be created."
;;; For the ESA help functions.
(defmethod help-stream ((frame climacs) title)
(typeout-window (format nil "~10T~A" title)))
;;; An implementation of the Gray streams protocol that uses a Climacs
;;; typeout pane to draw the output.
(defclass typeout-stream (fundamental-character-output-stream)
((%typeout-pane :accessor typeout-pane
:initform nil
:initarg :typeout-pane
:documentation "The typeout pane that output
will be performed on.")
(%climacs :reader climacs-instance
:initform (error "Must provide a Climacs instance for typeout streams")
:initarg :climacs)
(%label :reader label
:initform (error "A typeout stream must have a label")
:initarg :label))
(:documentation "An output stream that performs output on
a (single) Climacs typeout pane. If the typeout pane is deleted
manually by the user, the stream will recreate it the next time
output is performed."))
(defmethod initialize-instance :after ((stream typeout-stream) &rest args)
(declare (ignore args))
(setf (typeout-pane stream)
(with-look-and-feel-realization ((frame-manager (climacs-instance stream))
(climacs-instance stream))
(make-pane 'typeout-pane :foreground *foreground-color*
:background *background-color*
:width 900 :height 400 :display-time nil :name (label stream)))))
(defgeneric ensure-typeout-pane-for-stream (stream)
(:documentation "Ensure that `stream' has a typeout pane that
it can display output to, and that this pane is on display."))
(defmethod ensure-typeout-pane-for-stream ((stream typeout-stream))
(with-look-and-feel-realization ((frame-manager (climacs-instance stream))
(climacs-instance stream))
(unless (member (typeout-pane stream) (windows (climacs-instance stream)))
(setf (sheet-parent (typeout-pane stream)) nil)
(multiple-value-bind (vbox new-pane) (make-typeout-constellation :pane (typeout-pane stream)
:label (label stream))
(let* ((current-window (current-window))
(constellation-root (find-parent current-window)))
(push new-pane (windows *esa-instance*))
(other-window)
(replace-constellation constellation-root vbox t)
(full-redisplay current-window))))))
(defmethod stream-write-char ((stream typeout-stream) char)
(ensure-typeout-pane-for-stream stream)
(stream-write-char (typeout-pane stream) char))
(defmethod stream-line-column ((stream typeout-stream))
(ensure-typeout-pane-for-stream stream)
(stream-line-column (typeout-pane stream)))
(defmethod stream-start-line-p ((stream typeout-stream))
(ensure-typeout-pane-for-stream stream)
(stream-start-line-p (typeout-pane stream)))
(defmethod stream-write-string ((stream typeout-stream) string &optional (start 0) end)
(ensure-typeout-pane-for-stream stream)
(stream-write-string (typeout-pane stream) string start end))
(defmethod stream-terpri ((stream typeout-stream))
(ensure-typeout-pane-for-stream stream)
(stream-terpri (typeout-pane stream)))
(defmethod stream-fresh-line ((stream typeout-stream))
(ensure-typeout-pane-for-stream stream)
(stream-fresh-line (typeout-pane stream)))
(defmethod stream-finish-output ((stream typeout-stream))
(ensure-typeout-pane-for-stream stream)
(stream-finish-output (typeout-pane stream)))
(defmethod stream-force-output ((stream typeout-stream))
(ensure-typeout-pane-for-stream stream)
(stream-force-output (typeout-pane stream)))
(defmethod stream-clear-output ((stream typeout-stream))
(ensure-typeout-pane-for-stream stream)
(stream-clear-output (typeout-pane stream)))
(defmethod stream-advance-to-column ((stream typeout-stream) (column integer))
(ensure-typeout-pane-for-stream stream)
(stream-advance-to-column (typeout-pane stream) column))
(defmethod interactive-stream-p ((stream typeout-stream))
(ensure-typeout-pane-for-stream stream)
(interactive-stream-p (typeout-pane stream)))
(defun make-typeout-stream (climacs label)
(make-instance 'typeout-stream :climacs climacs :label label))
(defmethod invoke-with-help-stream ((frame climacs) title continuation)
(with-typeout (stream title)
(funcall continuation stream)))
......@@ -39,7 +39,6 @@
#:climacs-buffer #:external-format
#:climacs-pane
#:climacs-info-pane
#:typeout-pane #:typeout-pane-p
#:kill-ring
;; View-stuff
......@@ -47,13 +46,12 @@
#:view-setting-error #:view
#:unknown-view
#:view-already-displayed #:window
#:switch-to-pane #:remove-other-use #:remove-other-pane #:clone-view #:cancel
#:remove-other-use #:remove-other-pane #:clone-view #:cancel
#:any-view #:any-undisplayed-view
#:clone-view-for-climacs
#:make-new-view-for-climacs
;; GUI functions follow.
#:point
#:syntax
#:mark
......@@ -63,15 +61,14 @@
#:groups
#:display-window
#:split-window
#:typeout-window
#:delete-window
#:other-window
#:buffer-pane-p
#:display-view-info-to-info-pane
#:display-view-status-to-info-pane
;; Some configuration variables
#:*bg-color*
#:*fg-color*
#:*info-bg-color*
#:*info-fg-color*
#:*mini-bg-color*
......@@ -85,7 +82,11 @@
#:base-table #:buffer-table #:case-table
#:development-table
#:info-table #:pane-table
#:window-table))
#:window-table
;; Typeout
#:typeout-view #:typeout-view-p
#:with-typeout #:invoke-with-typeout))
(defpackage :climacs-core
(:use :clim-lisp :drei-base :drei-buffer :drei-fundamental-syntax
......@@ -100,8 +101,6 @@
#:switch-to-view #:switch-or-move-to-view
#:make-new-buffer
#:make-new-named-buffer
#:erase-buffer
#:kill-view
#:filepath-filename
......
;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*-
;;; (c) copyright 2008 by
;;; Troels Henriksen (athas@sigkill.dk)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
;;; Typeout pane support.
(in-package :climacs-gui)
(defclass typeout-view (drei-view textual-view)
((%output-history :accessor output-history
:initform (make-instance 'standard-tree-output-record)
:initarg :output-history
:documentation "The output record history
that will be replayed whenever the views contents are shown.")
(%dirty :accessor dirty
:initform t
:initarg :dirty
:documentation "This value indicates whether the
output has changed since it was last replayed."))
(:metaclass modual-class)
(:documentation "A noneditable Drei view displaying an output
record history."))
(defun typeout-view-p (view)
"Return true if `view' is a typeout view, false otherwise."
(typep view 'typeout-view))
(defmethod handle-redisplay ((pane drei-pane) (view typeout-view) (region region))
(if (and (not (dirty view))
(find (output-history view)
(output-record-children (stream-output-history pane))))
(replay (stream-output-history pane) pane region)
(call-next-method)))
(defmethod display-drei-view-contents ((pane pane) (view typeout-view))
(with-output-recording-options (pane :record nil :draw t)
(with-bounding-rectangle* (x1 y1 x2 y2) (or (pane-viewport pane)
pane)
(draw-rectangle* pane x1 y1 x2 y2 :ink +background-ink+))
(replay-output-record (output-history view) pane))
(unless (eq (output-record-parent (output-history view))
(stream-output-history pane))
(setf (output-record-parent (output-history view)) nil)
(add-output-record (output-history view) (stream-output-history pane)))
(setf (dirty view) nil))
(defmethod bounding-rectangle* ((view typeout-view))
(if (output-history view)
(bounding-rectangle* (output-history view))
(values 0 0 0 0)))
(defun scroll-typeout-window (window y)
"Scroll `window' down by `y' device units, but taking care not
to scroll past the size of `window'. If `window' does not have a
viewport, do nothing."
(let ((viewport (pane-viewport window)))
(unless (null viewport) ; Can't scroll without viewport
(multiple-value-bind (x-displacement y-displacement)
(transform-position (sheet-transformation window) 0 0)
(scroll-extent window
(- x-displacement)
(max 0 (min (+ (- y-displacement) y)
(- (bounding-rectangle-height window)
(bounding-rectangle-height viewport)))))))))
(defmethod page-down ((pane sheet) (view typeout-view))
(scroll-typeout-window pane (bounding-rectangle-height (pane-viewport pane))))
(defmethod page-up ((pane sheet) (view typeout-view))
(scroll-typeout-window
pane (- (bounding-rectangle-height (pane-viewport pane)))))
(defun ensure-typeout-view (climacs label)
"Ensure that `climacs' has a typeout view with the name
`label', and return that view."
(check-type label string)
(or (find-if #'(lambda (view)
(and (typeout-view-p view)
(string= (name view) label)))
(views climacs))
(make-new-view-for-climacs climacs 'typeout-view
:name label)))
;; Because specialising on the type of `climacs' is so useful...
(defun invoke-with-typeout (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."
(let* ((typeout-view (ensure-typeout-view climacs label))
(pane-with-typeout (or (find typeout-view (windows climacs)
:key #'view)
(let ((pane (split-window t)))
(setf (view pane) typeout-view)
pane))))
(let ((new-record (with-output-to-output-record (pane-with-typeout)
(with-output-recording-options (pane-with-typeout :record t :draw t)
(funcall continuation pane-with-typeout)))))
(add-output-record new-record (output-history typeout-view))
(setf (dirty typeout-view) t))))
(defmacro with-typeout ((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
view."
`(invoke-with-typeout *esa-instance* ,label
#'(lambda (,stream)
,@body)))
;;; An implementation of the Gray streams protocol that uses a Climacs
;;; typeout view to draw the output.
(defclass typeout-stream (fundamental-character-output-stream)
((%climacs :reader climacs-instance
:initform (error "Must provide a Climacs instance for typeout streams")
:initarg :climacs)
(%label :reader label
:initform (error "A typeout stream must have a label")
:initarg :label))
(:documentation "An output stream that performs output on
a (single) Climacs typeout pane. If the typeout pane is deleted
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))
(stream-write-char typeout char)))
(defmethod stream-line-column ((stream typeout-stream))
(with-typeout (typeout (label stream))
(stream-line-column typeout)))
(defmethod stream-start-line-p ((stream typeout-stream))
(with-typeout (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))
(stream-write-string typeout string start end)))
(defmethod stream-terpri ((stream typeout-stream))
(with-typeout (typeout (label stream))
(stream-terpri typeout)))
(defmethod stream-fresh-line ((stream typeout-stream))
(with-typeout (typeout (label stream))
(stream-fresh-line typeout)))
(defmethod stream-finish-output ((stream typeout-stream))
(with-typeout (typeout (label stream))
(stream-finish-output typeout)))
(defmethod stream-force-output ((stream typeout-stream))
(with-typeout (typeout (label stream))
(stream-force-output typeout)))
(defmethod stream-clear-output ((stream typeout-stream))
(with-typeout (typeout (label stream))
(stream-clear-output typeout)))
(defmethod stream-advance-to-column ((stream typeout-stream) (column integer))
(with-typeout (typeout (label stream))
(stream-advance-to-column typeout column)))
(defmethod interactive-stream-p ((stream typeout-stream))
(with-typeout (typeout (label stream))
(interactive-stream-p typeout)))
(defun make-typeout-stream (climacs label)
(make-instance 'typeout-stream :climacs climacs :label label))
......@@ -99,11 +99,7 @@ clone of `(current-view)' for the new window."
(define-presentation-to-command-translator blank-area-to-switch-to-this-window
(blank-area com-switch-to-this-window window-table
:echo nil
;; Putting the point in typeout-panes can cause errors.
:tester ((object presentation)
(declare (ignore presentation))
(not (typep object 'typeout-pane))))
:echo nil)
(window x y)
(list window x y))
......@@ -152,26 +148,10 @@ clone of `(current-view)' for the new window."
'window-table
'((#\x :control) (#\1)))
(defun scroll-typeout-window (window y)
"Scroll `window' down by `y' device units, but taking care not
to scroll past the size of `window'. If `window' does not have a