Skip to content
Snippets Groups Projects
frames.lisp 15.8 KiB
Newer Older
cer's avatar
cer committed
;; -*- mode: common-lisp; package: clim -*-
cer's avatar
cer committed
;; 
;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
cer's avatar
cer committed
;; $fiHeader: frames.cl,v 1.4 92/01/02 15:33:14 cer Exp Locker: cer $
cer's avatar
cer committed

(in-package :clim)

cer's avatar
cer committed

;; Frame protocol:
;;   adopt-frame
;;   enable-frame
;;   generate-panes
;;   layout-frame
;;   make-application-frame

(defclass frame-manager () 
  ((port :reader port :initarg :port)))
	   


(defclass application-frame () 
  ((port :reader port :initarg :port)
   (graft :reader graft :initarg :graft)
   (frame-manager :reader frame-manager :initarg :frame-manager)
   (panes :initarg :panes :accessor frame-panes)
   (top-level-sheet :accessor frame-top-level-sheet :initform nil)
   (shell :accessor frame-shell)
cer's avatar
cer committed
   (state :initform :disowned :accessor frame-state 
	  :type (member :disowned :disabled :enabled :shrunk))
cer's avatar
cer committed
   (command-table :initarg :command-table 
		  :initform (find-command-table 'user-command-table)
		  :accessor frame-command-table)
   (top-level :initarg :top-level  :accessor frame-top-level)
cer's avatar
cer committed
   (current-layout :initarg :default-layout :reader frame-current-layout)
   (all-panes :initform nil)
   (pane-constructors :initarg :pane-constructors)
cer's avatar
cer committed
   )
  (:default-initargs
   :top-level 'default-frame-top-level
   :frame-manager (find-frame-manager)
   :port (find-port)
   :graft (find-graft)))

(defmethod frame-name ((frame application-frame))
  (format nil "~A" (type-of frame)))

cer's avatar
cer committed
(defmethod frame-pretty-name ((frame application-frame))
  (frame-name frame))

cer's avatar
cer committed
(defvar *frame-managers* nil)

(defun find-frame-manager (&rest options)
  (let ((port (apply #'find-port options)))
    (second (or (assoc port *frame-managers*)
		(car
		 (push (list port (make-frame-manager port))
		       *frame-managers*))))))

(defmethod make-frame-manager (port)
  (make-instance 'frame-manager :port port))
    

(defmethod initialize-instance :after ((frame application-frame) &rest
				       x &key frame-manager)
  (adopt-frame frame-manager frame))

(defmethod adopt-frame ((framem frame-manager) (frame application-frame))
  (generate-panes frame framem))
cer's avatar
cer committed

;; what is this???

cer's avatar
cer committed
(defmethod generate-panes ((frame application-frame) (framem
						      frame-manager))
  (setf (frame-panes frame) nil))



(defmacro define-application-frame (name superclasses slots &rest options)
  (unless superclasses (setq superclasses '(application-frame))) 
  (let ((pane (second (assoc :pane options)))
cer's avatar
cer committed
	(panes (cdr (assoc :panes options)))
	(layout (cdr (assoc :layout  options)))
cer's avatar
cer committed
	(command-definer (second (or (assoc :command-definer options)
				     '(t t))))
	(command-table (second (or (assoc :command-table options)
				   '(t t))))
	(top-level (assoc :top-level options)))
cer's avatar
cer committed
    
    (when (and pane panes)
      (error "Cannot use :pane and :panes together"))
    
    (when (or (and panes (null layout))
	      (and layout (null panes)))
      (error ":layout and :panes must be used together"))
    
cer's avatar
cer committed
    (cond ((null command-table))
	  ((symbolp command-table)
	   (setq command-table (list command-table))))
    
    (when (eq (car command-table) t)
      (setq command-table (list* name (rest command-table))))
	   
    `(progn
       (defclass ,name 
	   ,superclasses 
	   ,slots
	 (:default-initargs
cer's avatar
cer committed
	     ,@(and layout `(:default-layout ',(car (car layout))))
	   ,@(and top-level `(:top-level ',(second top-level)))
	   ,@(and panes `(:pane-constructors
			  ,(compute-pane-constructor-code panes)))
	   ,@(and command-table
		  `(:command-table (clim-internals::find-command-table ',(car command-table))))))
cer's avatar
cer committed
       ,@(when command-table
cer's avatar
cer committed
	   `((define-command-table ,(first command-table)
cer's avatar
cer committed
		 ,@(cdr command-table))))
cer's avatar
cer committed
       ,@(when command-definer
	   (compute-command-definer-code name command-table))
cer's avatar
cer committed
       ,@(compute-generate-panes-code name pane panes layout))))
cer's avatar
cer committed

(defmacro define-frame-command (command-table-name name-and-options arguments &body body)
  (multiple-value-bind (command-name command-options)
      (decode-name-and-options name-and-options command-table-name)
    `(define-command (,command-name :command-table ,command-table-name ,@command-options)
			   ,arguments
			   ,@body)))

(defun compute-command-definer-code (name command-table)
  (let ((command-definer (fintern "~A~A~A" `define- name '-command)))
    `((defmacro ,command-definer (command-name arguments &body body)
	`(define-frame-command ,',(first command-table)
				     ,command-name ,arguments ,@body)))))



cer's avatar
cer committed
(defun compute-generate-panes-code (name code panes layouts)
  (if panes
      (compute-complex-generate-panes-code name panes layouts)
    (compute-simple-generate-panes-code name code)))

(defun compute-simple-generate-panes-code (name code)
cer's avatar
cer committed
  (and code
       (let ((f (gensym))
	     (fm (gensym)))
	 `((defmethod generate-panes ((,f ,name) (,fm frame-manager))
	     (let ((*application-frame* ,f))
	       (setf (frame-panes ,f)
cer's avatar
cer committed
		 (frame-wrapper
		  ,f ,fm
		  (with-look-and-feel-realization 
		      (,fm ,f)
		    ,code)))))))))

cer's avatar
cer committed
(defun compute-complex-generate-panes-code (name panes layouts)
  (let ((f (gensym))
	(fm (gensym)))
    `((defmethod generate-panes ((,f ,name) (,fm frame-manager))
	(symbol-macrolet
	    ,(mapcar #'(lambda (pane-spec)
			 (destructuring-bind
			     (name code) pane-spec
			   `(,name (find-or-make-pane-named ,f
							    ',name))))
	      panes)

	  (let ((*application-frame* ,f))
	    (setf (frame-panes ,f)
	      (frame-wrapper
	       ,f ,fm
	       (with-look-and-feel-realization 
		   (,fm ,f)
		 (ecase (frame-current-layout ,f)
		   ,@(mapcar #'(lambda (layout-spec)
				 (destructuring-bind
				     (name panes) layout-spec
				   `(,name ,panes)))
			     layouts)))))))))))

(defun find-or-make-pane-named (frame name)
  (second (or (assoc name (slot-value frame 'all-panes))
	      (car (push
		    (list name 
			  (funcall (second (assoc name (slot-value frame 'pane-constructors)))
				   frame
				   (frame-manager frame)))
		    (slot-value frame 'all-panes))))))

(defun compute-pane-constructor-code (panes)
  `(list ,@(mapcar #'(lambda (pane-spec)
		      (destructuring-bind
			  (name code) pane-spec
			`(list ',name
			       #'(lambda (frame framem)
				   (with-look-and-feel-realization
				       (framem frame)
				     ,code)))))
		  panes)))
   
cer's avatar
cer committed
(defmethod frame-wrapper ((frame t) (framem t) pane)
  pane)
cer's avatar
cer committed

(defmacro with-look-and-feel-realization ((realizer frame) &rest forms)
  `(macrolet ((silica::realize-pane (&rest foo)
			    `(realize-pane-internal ,',realizer ,',frame ,@foo)))
     ,@forms))


(defmethod enable-frame ((frame application-frame))
  (ecase (frame-state frame)
    (:enabled)
    ((:disabled :disowned)
cer's avatar
cer committed
     (let ((old (frame-state frame)))
       (setf (frame-state frame) :enabled)
       ;; IF this is a new frame then if the user specified a width
       ;; then we should be using that
       ;; IF the frame already exists then we probably should be using
       ;; the top level sheet size
       (multiple-value-call
	   #'layout-frame 
	 frame
	 (ecase old
	   (:disowned (values))
	   (:disabled
	    (bounding-rectangle-size
	     (frame-top-level-sheet frame)))))
       (note-frame-enabled (frame-manager frame) frame)))))
cer's avatar
cer committed

(defmethod disable-frame ((frame application-frame))
  (ecase (frame-state frame)
cer's avatar
cer committed
    ((:disowned :disabled))
cer's avatar
cer committed
    ((:enabled :shrunk)
     (setf (frame-state frame) :disabled)
     (note-frame-disabled (frame-manager frame) frame))))

(defmethod layout-frame ((frame application-frame) &optional width height)
cer's avatar
cer committed
  (when (frame-panes frame)
    (unless (and width height)
      (let ((sr (compose-space (frame-panes frame))))
	(setq width (silica::space-req-width sr)
	      height (silica::space-req-height sr))))
    (allocate-space (frame-panes frame) width height)
    ;; This is quite likely not going to work
    (when (frame-top-level-sheet frame)
      (silica::resize-sheet* (frame-top-level-sheet frame)
			     width height))))
cer's avatar
cer committed

(defun make-application-frame (class &rest options &key enable &allow-other-keys)
  (with-rem-keywords (options options '(:enable))
		     (let ((frame (apply #'make-instance class options)))
		       (when enable (enable-frame frame))
		       frame)))

(defmethod note-frame-enabled ((framem frame-manager) frame)
  (declare (ignore frame)))

(defmethod note-frame-disabled (framem frame)
  (declare (ignore frame)))

(defmethod run-frame-top-level :around ((frame application-frame))
  (with-simple-restart (frame-exit "Exit ~A" (frame-pretty-name frame))
    (let ((*application-frame* frame))
      (call-next-method))))

(defmethod run-frame-top-level ((frame application-frame))
cer's avatar
cer committed
  (unwind-protect
      (progn
	(let ((tl (frame-top-level frame)))
	  (if (atom tl)
	      (funcall tl frame)
	    (apply (car tl) frame (cdr tl)))))
    (disable-frame frame)))
cer's avatar
cer committed

(defun command-enabled-p (command frame) t)
				
(defmethod default-frame-top-level (frame
				    &key command-parser command-unparser partial-command-parser
					 (prompt "Command: "))
cer's avatar
cer committed
  
  (unless (eq (frame-state frame) :enabled)
    (enable-frame frame))
cer's avatar
cer committed
  (loop
    (catch 'layout-changed
      (let* ((*standard-output* (or (frame-standard-output frame) *standard-output*))
	     (*query-io* (or (frame-query-io frame) *query-io*))
	     (interactor (find-frame-pane-of-type frame 'interactor-pane))
	     (*standard-input* (or interactor *standard-output*))
	     (*command-parser*
	      (or command-parser
		  (if interactor
		      #'command-line-command-parser
		    #'menu-only-command-parser)))
	     (*command-unparser*
	      (or command-unparser
		  #'command-line-command-unparser))
	     (*partial-command-parser*
	      (or partial-command-parser
		  (if interactor
		      #'command-line-read-remaining-arguments-for-partial-command
		    #'menu-only-read-remaining-arguments-for-partial-command))))
	(unless (typep *standard-input* 'excl::bidirectional-terminal-stream)
	  (assert (port *standard-input*)))
	(unless (typep *standard-output* 'excl::bidirectional-terminal-stream)
	  (assert (port *standard-output*)))
	(unless (typep *query-io* 'excl::bidirectional-terminal-stream)
	    (assert (port *query-io*)))
	(loop
	  (clim-utils::with-simple-abort-restart ("Abort Command")
	    (redisplay-frame-panes frame)
	    (when interactor
	      (fresh-line *standard-input*)
	      (if (stringp prompt)
		  (write-string prompt *standard-input*)
		(funcall prompt *standard-input* frame)))
	    (let ((command (read-frame-command frame :stream *standard-input*)))
	      (when interactor
		(terpri *standard-input*))
	      ;; Need this check in case the user aborted out of a command menu
	      (when command
		(execute-frame-command frame command)))))))))
cer's avatar
cer committed

(defmethod redisplay-frame-panes (frame &key force-p)
  (map-over-sheets #'(lambda (sheet)
		       (when (typep sheet 'basic-clim-interactor)
			 (redisplay-frame-pane frame sheet :force-p
					       force-p)))
		   (frame-top-level-sheet frame)))

(defun redisplay-frame-pane (frame pane &key force-p)
  (when (pane-display-function pane)
cer's avatar
cer committed
    (let* ((ird (slot-value pane 'incremental-redisplay-p))
	   (history 
	    (and ird 
		 (output-recording-stream-output-record pane)))
	   (record (and history
			(> (output-record-count history) 0)
			(output-record-element history 0))))
      (cond ((and ird (or force-p (null record)))
	     (when force-p
	       (window-clear pane))
	     (updating-output (pane)
			      (invoke-pane-redisplay-function frame pane)))
	    (ird
	     (redisplay record pane))
	    (t
	     (invoke-pane-redisplay-function frame pane))))))
cer's avatar
cer committed

(defun invoke-pane-redisplay-function (frame pane)
  (let ((fn (pane-display-function pane)))
    (if (atom fn)
	(funcall fn frame pane)
      (apply (car fn) frame pane (cdr fn)))))
			 
(defun execute-frame-command (frame command)
cer's avatar
cer committed
  (declare (ignore frame))
cer's avatar
cer committed
  (apply (command-name command) (command-arguments command)))

cer's avatar
cer committed

cer's avatar
cer committed
(defun frame-find-innermost-applicable-presentation (frame
							   input-context 
							   history-window px py)
  (find-innermost-applicable-presentation 
   input-context history-window px py))

(defmethod frame-maintain-presentation-histories (frame) nil)

(defvar *click-outside-menu-handler* nil)

(defmethod frame-input-context-button-press-handler
	   (frame stream button-press-event)
  (declare (ignore stream))
  (let* ((window (event-sheet button-press-event))
	 (x (pointer-event-x button-press-event))
	 (y (pointer-event-y button-press-event))
	 (highlighted-presentation (highlighted-presentation window nil))
	 (input-context *input-context*))
    #+excl
    (when (and *click-outside-menu-handler*
		(output-recording-stream-p window)
		(not 
		 (region-contains-point*-p 
		 (output-recording-stream-output-record window) x y)))
      (funcall *click-outside-menu-handler*))
    
    (when highlighted-presentation
      ;; Unhighlight on the way out.
      ;; But only unhighlight the window that the click is from. 
      (unhighlight-highlighted-presentation window nil))
    (throw-highlighted-presentation 
      (or (and (output-recording-stream-p window)
	       (frame-find-innermost-applicable-presentation
		frame input-context window x y))
	  *null-presentation*)
      input-context
      button-press-event)))

(defun find-frame-pane-of-type (frame type)
  (map-over-sheets 
   #'(lambda (sheet)
       (when (typep  sheet type)
	 (return-from find-frame-pane-of-type sheet)))
   (frame-top-level-sheet frame)))

(defun map-over-sheets (fn sheet)
  (funcall fn sheet)
  (when (typep sheet 'silica::sheet-parent-mixin)
    (dolist (child (sheet-children sheet))
      (map-over-sheets fn child))))

(defmethod frame-standard-output (frame)
  (find-frame-pane-of-type frame 'application-pane))

(defmethod frame-standard-input (frame)
  (find-frame-pane-of-type frame 'interactor-pane))

(defmethod frame-query-io (frame)
  (or (frame-standard-input frame)
      (frame-standard-output frame)))

;; frame-query-io
;; frame-pointer-documentation


  
(defmethod read-frame-command ((frame application-frame) 
			       &key (stream *query-io*)		;frame-query-io?
			       ;; should the rest of the *command-parser*
			       ;; etc. variables be passed as keywords or bound?
			       )
  (read-command (frame-command-table frame) :stream stream))

(defmethod frame-exit ((frame application-frame))
  (invoke-restart 'frame-exit))
cer's avatar
cer committed

(defmethod (setf frame-current-layout) (nv (frame application-frame))
  (unless (eq (frame-current-layout frame) nv)
    (setf (slot-value frame 'current-layout) nv)
    ;; Top level sheet should loose all its child annd then we should 

    (dolist (name-and-pane (slot-value frame 'all-panes))
      (let ((sheet (second name-and-pane)))
	(when (silica::sheet-parent sheet)
	  (silica::disown-child (silica::sheet-parent sheet) sheet))))
    
    (dolist (child (sheet-children (frame-top-level-sheet frame)))
      (silica::disown-child (frame-top-level-sheet frame) child))
    
    ;; Now we want to give it some new ones
    (generate-panes frame (frame-manager frame))
    (adopt-child (frame-top-level-sheet frame) (frame-panes frame))
    (silica::clear-space-req-caches-in-tree (frame-panes frame))
    (multiple-value-call #'layout-frame
      frame
      (bounding-rectangle-size
       (frame-top-level-sheet frame)))
    (print 'throwing excl:*initial-terminal-io*)
    (throw 'layout-changed nil)))