;;; command-interface/command-utils.scm

;;; These are utilities used by the command interface.

;;; These send output to the user

;;; This is used in emacs mode

(define (say/em . args)
  (say1 args))

;;; This is for both ordinary text to emacs and output to the command interface

(define (say . args)
  (say1 args))

(define (say1 args)
  (apply (function format) (cons (current-output-port) args)))

;;; This is for non-emacs output

(define (say/ne . args)
  (when (not *emacs-mode*)
     (say1 args)))


;;; These random utilities should be elsewhere

;;; This determines whether the current module is loaded & available.
;;; If the module is Main, an empty Main module is created.

(define (cm-available?)
  (cond ((table-entry *modules* *current-mod*)
	 '#t)
	((eq? *current-mod* '|Main|)
	 (make-empty-main)
	 '#t)
	(else
	 '#f)))

;;; This creates a empty module named Main to use as a scratch pad.

(define (make-empty-main)
  (compile/load "$PRELUDE/Prelude")
  (setf *unit* '|Main|)
  (setf *current-mod* '|Main|)
  (let ((mods (parse-from-string
	       "module Main where {import Prelude}"
	       (function parse-module-list)
	       "foo")))
    ;;; This should generate no code at all so the returned code is ignored.
    (modules->lisp-code mods)
    (setf (table-entry *modules* *current-mod*) (car mods))
    (clear-extended-modules)))

(define (eval-fragment eval?)
  (cond ((not (cm-available?))
	 (say "~&Module ~A is not loaded.~%" *current-mod*)
	 'error)
	((memq *fragment-status* '(Compiled Saved))
	 (when eval?
	     (eval-module *extension-module*))
	 'ok)
	((eq? *fragment-status* 'Error)
	 (say/ne "~&Errors exist in current fragment.~%")
	 'error)
	((string=? *current-string* "")
	 (say/ne "~&Current extension is empty.~%")
	 'error)
	(else
	 (let ((res (compile-fragment
		     *current-mod* *current-string*
		     *extension-file-name*)))
	   (cond ((eq? res 'error)
		  (setf *fragment-status* 'Error)
		  (notify-error))
		 (else
		  (setf *extension-module* res)
		  (setf *fragment-status* 'Compiled)
		  (when eval?
			(eval-module *extension-module*))))))))

(define (set-current-file file)
  (cond ((null? file)
	 '())
	((null? (cdr file))
	 (setf *remembered-file* (car file)))
	(else
	 (say "~&Invalid file spec ~s.~%" file)
	 (funcall *abort-command*))))

(define (select-current-mod mods)
  (when (pair? mods)
    (when (not (memq *current-mod* mods))
      (setf *current-mod* (car mods))
      (say/ne "~&Now in module ~A.~%" *current-mod*))))

;;;  Emacs mode stuff

;;; *** bogus alert!!!  This coercion may fail to produce a
;;; *** real character in some Lisps.

(define *emacs-notify-char* (integer->char 1))

(define (notify-ready)
  (when *emacs-mode*
     (say/em "~Ar" *emacs-notify-char*)
     (force-output (current-output-port))))

(define (notify-input-request)
  (when *emacs-mode*
     (say/em "~Ai" *emacs-notify-char*)
     (force-output (current-output-port))))

(define (notify-error)
  (when *emacs-mode*
     (say/em "~Ae" *emacs-notify-char*)
     (force-output (current-output-port))))

(define (notify-printers printers)
  (notify-settings "p" printers))

(define (notify-optimizers optimizers)
  (notify-settings "o" optimizers))

(define (notify-settings flag values)
  (when *emacs-mode*
    (say/em "~A~A(" *emacs-notify-char* flag)
    (dolist (p values)
      (say/em " ~A" (string-downcase (symbol->string p))))
    (say/em ")~%")
    (force-output (current-output-port))))

(define (notify-status-line str)
  (when *emacs-mode*
     (say/em "~As~A~%" *emacs-notify-char* str)
     (force-output (current-output-port))))

;;; These are used to drive the real compiler. 

(define *compile/compile-cflags*
  (make cflags
	(load-code?          '#t)
	(compile-code?       '#t)
	(write-code?         '#t)
	(write-interface?    '#t)))


(define (compile/compile file)
  (haskell-compile file *compile/compile-cflags*))


(define *compile/load-cflags*
  (make cflags
	(load-code?          '#t)
	(compile-code?       '#f)
	(write-code?         '#f)
	(write-interface?    '#f)))

(define (compile/load file)
  (haskell-compile file *compile/load-cflags*))


;;; Printer setting support

(define (set-printers args mode)
  (set-switches *printers* (strings->syms args)
		mode *all-printers* "printers"))

(define (set-optimizers args mode)
  (set-switches *optimizers* (strings->syms args)
		mode *all-optimizers* "optimizers"))

(define (set-switches current new mode all name)
  (dolist (s new)
    (when (and (not (eq? s 'all)) (not (memq s all)))
      (signal-invalid-value s name all)))
  (let ((res (cond ((eq? mode '+)
		    (set-union current new))
		   ((eq? mode '-)
		    (set-difference current new))
		   ((eq? mode '=)
		    (if (equal? new '(all))
			all
			new)))))
    res))

(define (signal-invalid-value s name all)
  (recoverable-error 'invalid-value
    "~A is not one of the valid ~A.  Possible values are: ~%~A"
    s name all))

(define (print-file file)
  (call-with-input-file file (function write-all-chars)))

(define (write-all-chars port)
  (let ((line  (read-line port)))
    (if (eof-object? line)
	'ok
	(begin
	  (write-line line)
	  (write-all-chars port)))))

(define (strings->syms l)
  (map (lambda (x)
	 (string->symbol (string-upcase x)))
       l))