;;; -*- Mode:Common-Lisp; Package:Yes-Way; Base:10 -*-

;;; **********************************************************************
;;; Copyright (c) 1990 Stanford University.
;;; This code was written by James Rice.
;;; Copyright is held by Stanford University except where code has been
;;; modified from TI source code.  In these cases TI code is marked with
;;; a suitable comment.

;;; All Stanford Copyright code is in the public domain.  This code may be
;;; distributed and used without restriction as long as this copyright
;;; notice is included and no fee is charged.  This can be thought of as
;;; being equivalent to the Free Software Foundation's Copyleft policy.

;;; TI source code may only be distributed to users who hold valid TI
;;; software licenses.

;;; The development of this software was assisted by the following grants:
;;; Biomedical Research Technology Program of the National Institutes
;;; of Health under grant RR-00785
;;; Information Systems Technologies office of the Defense Advanced
;;; Research Projects Agency under contract N00039-86-C0033.

;;; **********************************************************************

;-------------------------------------------------------------------------------

(defun yw-error (&rest args)
"Signal an error."
  (with-standard-io-environment (apply 'ferror nil args))
)

(tv:defun-rh parse-error (&rest args)
"Signals a parse error."
;  (dbg)
  (beep)
  (if (typep (sys:follow-syn-stream *standard-input*) 'tv:stream-mixin)
      (send *standard-input* :Send-If-Handles :Eval-Inside-Yourself
	    `(tv:rh-set-position (tv:rh-scan-pointer))
      )
      nil
  )
  (format-scroll-window nil ">>Error: ~A" (apply 'format nil args))
  (with-standard-io-environment (apply 'si:parse-ferror args))
)

(defun yw-warn (&rest args)
"Issue a warning."
  (with-standard-io-environment
    (if *just-warn-for-warnings*
	(progn (format *query-io* "~%~%Warning: ")
	       (apply 'format *query-io* args)
	       (terpri *query-io*)
	       (send *query-io* :Clear-Input)
	       (signal 'sys:abort "Abort")
	)
	(apply 'ferror nil args)
    )
  )
)

(Defun mail-control-window-width ()
"A user hook for the specification of the width of mail control windows."
  (min *Mail-Control-Window-Width* (send tv:default-screen :Width))
)

(Defun mail-control-window-height ()
"A user hook for the specification of the height of mail control windows."
  (min *Mail-Control-Window-Height* (send tv:default-screen :Height))
)

(Defun all-mailer-command-tables ()
"Returns the list of all of the command tables used by the mailer."
  *all-mailer-command-tables*
)

(defun initial-active-mailer-command-tables ()
"Returns the list of initially active command tables fore the mailer."
  *initial-active-mailer-command-tables*
)

(defun yw-completion-handler ()
"Returns a completion handler like the normal handler except it uses the YW
complete word completer.
"
  (let ((array (make-array (array-dimensions tv:rh-completion-handler))))
       (loop for i
	     from 0
	     to (- (array-active-length tv:rh-completion-handler) 1)
	     do (setf (aref array i) (aref tv:rh-completion-handler i))
       )
       (setf (tv:complete-word-function array) 'tv:yw-rh-complete-word)
       array
  )
)

(defun mailer-command-loop (window)
"The top level loop used by the mailer.  Starts up the UCL command loop."
  (declare (special ucl:key-sequence))
  (let ((*terminal-io* (send window :Get-Pane :prompt-window))
	(*Mailer* window)
       )
       (declare (special *Mailer* *terminal-io*))
       (let ((*standard-input* *terminal-io*)
	     (*standard-output* *terminal-io*)
	     (tv:rh-completion-handler (yw-completion-handler))
	    )
	    (declare (special *standard-input* *standard-output*
			      tv:rh-completion-handler
		     )
	    )
	    (setq ucl:key-sequence nil)
	    (loop for ch = (send *terminal-io* :any-tyi-no-hang)
		  until (not ch)
            )
	    (send window :set-prefix-argument nil)
	    (Send window :Command-Loop)
       )
  )
)

(defun imap-client-top-level (window)
"The top level function for the IMAP client.  Just loops around calling
mailer-command-loop.  This allows me to change mailer-command-loop without
having to reset the process under Window.
"
  (loop (error-restart ((abort error) "Return to IMAP client command level.")
	  (mailer-command-loop window)
	)
	(tv:deselect-and-maybe-bury-window window :first)
  )
)

(defun user-prompt-window-inits ()
"A user hook that allows the user to specify an init plist for prompt windows.
This is the programatic hook *user-prompt-window-inits* can be used if the
init plist is constant.
"
  *user-prompt-window-inits*
)

(defun user-mailbox-selector-inits ()
"A user hook that allows the user to specify an init plist for mailbox selector.
This is the programatic hook *user-mailbox-selector-inits* can be used if the
init plist is constant.
"
  *user-mailbox-selector-inits*
)

(defun mail-control-window-panes ()
"Returns the constaint frame panes list for the mailer.  Note the inits for
the panes are computed at run-time.  This allows user modification of these.
"
  `((:Mailbox-Selector Mailbox-Selector :Owner ,self
		       ,@(user-mailbox-selector-inits)
    )
    (:Process-Status process-status-pane ,@(process-status-window-inits))
    (:System-Output system-output-pane ,@(system-output-window-inits))
    (:Prompt-Window Yw-prompt-window ,@(user-prompt-window-inits))
   )
)

(defun mail-control-window-constraints ()
"Returns the constraints for the mailer.  The number of lines in each pane
is computed at run-time to allow the user to modify them.
"
  `((:Main-Configuration
     (:Mailbox-Selector :Process-Status :System-Output :Prompt-Window)
     ((:Mailbox-Selector ,(Mailbox-Selector-Default-Number-Of-Lines) :Lines))
     ((:Process-Status ,(process-status-pane-default-number-of-lines) :Lines))
     ((:system-output ,(system-output-pane-default-number-of-lines) :Lines))
     ((:Prompt-Window :Even))
    )
   )
)

(defflavor mail-control-window
	   ((all-summary-windows nil) ; List of summary windows for the mailer.
	    (all-prompts '((*Top-Level-Command-Table* "YW>")))
	      ; an alist that maps the active command table to all of the
	      ; prompts to use in the mail prompt window.
	    (message-sequence-command-tables
	      '(*message-sequence-command-table*)
	    ) ; The command tables to use when reading message sequences.
	    (all-mailboxes nil) ; A list of mailboxes.
	    (current-mailbox nil) ; the current mailbox.
	    (current-summary-window nil) ; the current summary window.
	    mailbox-selector ; The mailbox selector pane
	    prompt-window ; the prompt pane
	    system-output-pane ; the scrolling system message pane.
	    process-status-pane ; the process status window, sleep, etc.
;	    (command-executed-immediately nil) ; a flag that is set to true when
;	      ; the current command was executed immediately (before a CRLF).
	    (current-bboard nil) ; the current bboard in the FIND list.
	    (operator-command-tables
	      '(*operator-command-table*)
	    ) ; a list of the command tables used for operators (FROM, TO etc.)
	    (prefix-argument nil) ; The current prefix argument
	    (current-sequence nil) ; the current message sequence object or nil.
	    (icon nil) ; the icom for the mail control window.
	   )
	   (Ucl:selective-features-mixin
	    ucl:basic-command-loop
	    tv:process-mixin
	    tv:full-screen-hack-mixin
	    tv:frame-dont-select-inferiors-with-mouse-mixin
	    tv:bordered-constraint-frame-with-shared-io-buffer
	   )
  (:Default-Init-Plist
    :Remove-Features '(:Lisp-Typein)
    :All-Command-Tables (all-mailer-command-tables)
    :Active-Command-Tables (initial-active-mailer-command-tables)
    :Typein-Handler :Handle-Typein-Input
    :Inhibit-Results-Print? T
    :Print-Results? 'print-results-p
    :Process '(Imap-Client-Top-Level
		:special-pdl-size 4000
		:regular-pdl-size 10000
	      )
    :Height (mail-control-window-height)
    :Width (mail-control-window-width)
    :Prompt 'compute-prompt
    :Expose-P t
    :Activate-P t
    :Save-Bits t
    :Deexposed-Typeout-Action :Permit
    :More-P nil
    :Panes (Mail-Control-Window-Panes)
    :Constraints (Mail-Control-Window-Constraints)
  )
  :Initable-Instance-Variables
  :Settable-Instance-Variables
  :Gettable-Instance-Variables
  (:Documentation "The flavor used for the frame of mailers in the IMAP client."
  )
)

(defmethod (mail-control-window :shrink-to-icon) ()
  (w:shrink-random-window self)
  (if *shrink-summary-windows-with-control-window*
      (loop for (name window) in (send self :All-Summary-Windows)
	    when (send window :active-p)
	    do (w:shrink-window window)
      )
      nil
  )
)

(defmethod (Mail-Control-Window :After :Set-Current-Mailbox) (to)
  (ignore to)
  (send prompt-window :Set-Label (send self :Make-Label))
)

(defmethod (Mail-Control-Window :Before :Set-Prefix-Argument) (to)
  (letf ((#'sys:internal-read-char
	  (or *old-internal-read-char* #'sys:internal-read-char)
	 )
	)
        (loop for message in (set-difference prefix-argument to) do
	      (send message :remove-selected-type :Prefix-Arg)
	)
  )
)

(defun yw-read-from-string (&rest args)
  (letf ((#'sys:internal-read-char
	  (or *old-internal-read-char* #'sys:internal-read-char)
	 )
	)
	(apply 'read-from-string args)
  )
)

(defmethod (Mail-Control-Window :After :Set-Prefix-Argument) (to)
  (ignore to)
  (send process-status-pane :Maybe-Display-Statuses t)
)

(defmethod (Mail-Control-Window :After :set-current-sequence) (to)
  (ignore to)
  (send prompt-window :Set-Label (send self :Make-Label))
)

;-------------------------------------------------------------------------------

(if (get 'mailer-windows 'defresource)
    (Check-Window-Resource 'mailer-windows 'mail-control-window)
    nil
)