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

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)))
......
This diff is collapsed.
......@@ -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
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)))))))))
(define-command (com-scroll-other-window :name t :command-table window-table) ()
(let ((other-window (second (windows *application-frame*))))
(when other-window
(if (typeout-pane-p other-window)
(scroll-typeout-window other-window (bounding-rectangle-height (pane-viewport other-window)))
(page-down (view other-window))))))
(page-down other-window (view other-window)))))
(set-key 'com-scroll-other-window
'window-table
......@@ -180,9 +160,7 @@ viewport, do nothing."
(define-command (com-scroll-other-window-up :name t :command-table window-table) ()
(let ((other-window (second (windows *application-frame*))))
(when other-window
(if (typeout-pane-p other-window)
(scroll-typeout-window other-window (- (bounding-rectangle-height (pane-viewport other-window))))
(page-up (view other-window))))))
(page-up other-window (view other-window)))))
(set-key 'com-scroll-other-window-up
'window-table
......
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