(in-package "KPML")

;;; File: message.lisp
;;;
;;; Contains various functions for giving message of various severity
;;; to the user during use of KPML...
;;;
;;; 2.1 demo mode enforced more strongly...
;;; 3.1 cleared of clisp.

(defvar messages nil "The messages issues during a session")

;;; Following used to be additionally sensitive to the value
;;; of fast-flag, which disables system sorting during traversal.
;;; Speed is in any case not much of an issue here. 
;;; John:IPSI:Dec94.

(defun CAUTION (&REST args)
  (when (and (not *demo-mode*) show-cautions-flag)
;; fast-flag ;recording cautions is slow due to format, 
;; dont record if in fast mode.
    (incf Caution-Count)
    (let ((caution-string 
	   (format nil "Caution # ~a   --   " caution-count)))
      (dolist (arg args)
	(setq caution-string (format nil "~a~a" caution-string arg)))
      (push caution-string cautions)
      (printwindow :display-pane 
		   (cons " " (indent-and-fill caution-string))))))

;;; ----------------------------------------------------------------------
;;; KPML 0.8: additional function for giving information, not
;;;   ranked even as a caution, just because it is useful...
;;; 
;;;  2.1 extended to produce nicer output for longer strings. Now used
;;;      as a way of avoiding some Lisp's (e.g., ACL3pc) dislike of newlines
;;;      in their format strings and of making such code more portable.
;;;      Also tries to make sure that the arguments are all acceptable
;;;      so that touchy lisps that don't like autoconverting, e.g.,
;;;      paths to strings (mentioning no names Lispworks) don't get
;;;      upset.
;;; ----------------------------------------------------------------------

(defvar *MESSAGE-ID-STRING* ";(KPML) ")

(defun MESSAGE (&REST args)
  ;; 2.1 be very cautious here for different Lisps...
  ;;     have to be very sure that we get something that is
  ;;     appropriate for passing to concat...
  (unless *demo-mode*
    (let ((stringified-args 
	   (mapcar #'(lambda (arg)
		       (typecase arg
		         (string arg)
		         (otherwise
			  (format nil "~A" arg))))
		   args)))
      (push (apply #'concat stringified-args) messages)
      (printwindow :display-pane 
		   (cons " " 
		         (indent-and-fill stringified-args 
					  :indent-string *message-id-string*
					  :right-margin-p T
					  :right-margin 55))))))

;;; ----------------------------------------------------------------------
;;; The standard warning presentation function...
;;;
;;; 0.9 during example running, warnings are sent to the standard output
;;;     which is often the file where the example runner results are
;;;     being sent. They are therefore commented.
;;;
;;; 2.0.18
;;; Functions here still had some conditionalizations that only covered
;;; ACL-PC and not Harlequin Lispworks PC (for PC-unsupported pretty
;;; printing).
;;; ----------------------------------------------------------------------

(defun WARNING (&rest args)
  ;; 2.0.18 
  (apply #'kpml-warning args))


(defun KPML-WARNING (&rest args) 
  (unless *demo-mode*
    (incf warning-count)
    (let ((warning-string (format nil "Warning # ~a   --   " warning-count)))
      (dolist (arg args)
	(setq warning-string (format nil "~a~a" warning-string arg)))
      (push warning-string warnings)
      (cond (example-runner-flag
	     (terpri)
	     ;; 2.0.18 conditionalization broadened.
	     #-(or acl3.0 lispworks4)
	     (let ((*print-right-margin* 40))
	       (pprint-logical-block 
		(nil nil :per-line-prefix ";;; ")
		(format t "~{~%~A~}" (indent-and-fill warning-string))))
	     #+(or acl3.0 lispworks4)
	     (format t "~{~%;;; ~A~}" 
		     (indent-and-fill warning-string))
	     )
	    (t
	     (printwindow :display-pane (indent-and-fill " "))
	     (printwindow :display-pane (indent-and-fill warning-string))))
      (When Warning-Stop-Flag (break)))))


(DEFUN Report-Warnings (&optional (StartWith 1) (HowMany (length warnings)))
  (printwindow :display-pane (indent-and-fill "The warnings in order of occurrence:"))
  (PROG ((WW (nthcdr (- (cond (startwith startwith)
			      (t 1)) 1)
		     (reverse warnings))))
	(loop for W in WW as NN from 1 to  (cond (howmany howmany)
						 (t (setq howmany 999))) 
	      when (< NN  (- howmany 2))
	      do
	      (printwindow :display-pane (indent-and-fill w))))
  (let ((current-warnings (+ (- howmany startwith) 1)))
    (cond ((equal current-warnings 0)
	   (printwindow
	     :display-pane
	     (indent-and-fill
	       (format nil "There were no errors or warnings." ))))
	  ((equal current-warnings 1)
	   (printwindow
	     :display-pane
	     (indent-and-fill
	       (format nil "There was one error or warning." ))))
	  (t
	   (printwindow
	     :display-pane
	     (indent-and-fill
	       (format nil "There were ~a errors and warnings." (+ (- howmany startwith) 1)))))))
  Warning-Count)

(defun print-answerset-warning (answer grammar-inquiry source)
  (when *show-inquiry-answer-source*
    (printwindow
      :display-pane
      (indent-and-fill (format nil "System: ~a " Message-Sender) :left-margin 0))
    (printwindow
      :display-pane
      (indent-and-fill (format nil "Inquiry: ~a " Grammar-Inquiry) :left-margin 2))
    (printwindow
      :display-pane
      (indent-and-fill
	(format nil "Inquiry Answer From ~a: ~a " source answer) :left-margin 4))
    (printwindow
      :display-pane
      (indent-and-fill (format nil "Answer Not In Allowable Answer Set: ~a "
			       (fetch-inquiry-info (CAR grammar-Inquiry) 'answerset)) :left-margin 6))))


;;; 0.9 selective inquiry tracing added...
(defun PRINT-RESPONSE (&optional ITEM Inquiry)
  (cond (window-interface-flag    
	 (when (or english-trace-flag 
		   (member inquiry *traced-inquiries*))
	   (printwindow :inquiry-response-pane 
			(format nil "~a~30T~a" inquiry item))))
	(T (cond
	     ((Or (NIGEL-NLISTP ITEM) (< (LENGTH ITEM) English-Print-Length))
	      (printwindow
		:display-pane
		(indent-and-fill
		  (format nil "Environment's answer to the system network is ~a" item) :left-margin 7)))  
	     (T
	      (printwindow
		:display-pane
		(indent-and-fill
		  (format nil "Environments answer is a list of ~a items, beginning with ~a"
			  (LENGTH ITEM) (CAR ITEM))))))))
  (when stop-action-flag
    (askwindow :any-key-to-continue "Hit any key to continue.")))

(defun UNIMPLEMENTED (printstring)
  (printwindow
    :display-pane
    (indent-and-fill printstring)))
