(herald condition)                                          ; -*- T -*-

;;;; T Condition System

;;; This is a preliminary implementation to demonstrate the design.

;;; It should, in the real implementation, be factored into several
;;; different modules.

;;;; Condition Handlers

(lset *condition-handlers* '())

(define (signal-condition condition)
  (let ((default-handler (default-condition-handler condition)))
    (iterate loop ((condition condition)
                   (handlers *condition-handlers*))
      (if (null? handlers)
          (default-handler condition)
          (let ((more (cdr handlers)))
            (loop (bind ((*condition-handlers* more))
                    ((car handlers) condition))
                  more))))))

(define (signal-ignorably displayer condition)
  (with-exiting-restarter restart/ignore? 'ignore displayer
      condition
    (lambda (r)
      (ignore r)
      (signal-condition condition))))

(define (signal-substitutably displayer substitute-reader condition)
  (with-value-substitution-restarter displayer substitute-reader
      condition
    (lambda (r)
      (ignore r)
      (signal-condition condition))))

(define (with-condition-handler handler thunk)
  (bind ((*condition-handlers* (cons handler *condition-handlers*)))
    (thunk)))

(define (with-exiting-condition-handler predicate handler thunk)
  (catch return
    (handler (catch enter-handler
               (with-condition-handler
                   (filtered-condition-handler predicate enter-handler)
                 (lambda ()
                   (receive-values return thunk)))))))

(define (with-exiting-condition-handler* predicate handler thunk
          procedure)
  ((with-exiting-condition-handler (lambda (c) (lambda () (handler c)))
     (lambda ()
       (receive results (thunk)
         (lambda ()
           (apply procedure results)))))))

(define-integrable (filtered-condition-handler filter handler)
  (lambda (condition)
    (if (filter condition)
        (handler condition)
        condition)))                    ; Decline to handle: resignal.

(define (trap-errors thunk)
  (catch exit
    (with-condition-handler (filtered-condition-handler error? exit)
      thunk)))

(define (ignore-conditions thunk)
  (with-condition-handler
      (lambda (c)
        (cond ((find-restarter restart/ignore? c)
               => (lambda (r) (r)))     ; Restart.
              (else c)))                ; Decline/resignal.
    thunk))

(define (ignore-conditions-if pred thunk)
  (with-condition-handler
      (lambda (c)
        (let ((r (find-restarter restart/ignore? c)))
          (if (and r (pred c))
              (r)                       ; Restart.
              c)))                      ; Decline/resignal.
    thunk))

;;;; Condition Objects & Taxonomy

(define-predicate condition?)

(define-operation (default-condition-handler condition)
  (if (serious-condition? condition)
      (standard-serious-condition-handler)
      (lambda (condition)
        (ignore condition)
        no-default-condition-handler)))

(define no-default-condition-handler
        (undefined-value "no default condition handler"))

;;; E.g., (NOTE "closing garbage-collected port~%~S" PORT) might print
;;; as the following, since NOTE passes ";" for the PREFIX & "Note" for
;;; the TYPE:
;;;
;;;   ;Note: closing garbage-collected port
;;;   ;      #{Port FROBBOTZ 123}

(define (standard-display-condition port prefix type fmt args)
  (fresh-line port)
  (apply format
         (join (let ((spaces
                      (string-fill (make-string
                                    (fx+ 2 (string-length type)))
                                   #\space)))
                 (object nil
                   ((newline self)
                    (newline port)
                    (write-string port prefix)
                    (write-string port spaces))))
               port)
         "~A~A: ~K"
         prefix type fmt args)
  (newline port))

;;;;; Non-Serious Conditions:  Notes & Warnings

(define-predicate note?)

(define (make-formatted-note fmt args)
  (object nil
    ((condition? self) '#t)
    ((note?      self) '#t)
    ((display self port)
     (standard-display-condition port ";" "Note" fmt args))))

(define (note fmt . args)
  (signal-ignorably "Ignore the note."
                    (make-formatted-note fmt args)))

(define-predicate warning?)

(define (make-formatted-warning fmt args)
  (object nil
    ((condition? self) '#t)
    ((warning?   self) '#t)
    ((display self port)
     (standard-display-condition port ";** " "Warning" fmt args))
    ((default-condition-handler self)
     (standard-warning-handler))))

(define (warning fmt . args)
  (signal-ignorably "Ignore the warning."
                    (make-formatted-warning fmt args)))

(define-simple-switch standard-warning-handler
  procedure?
  (lambda (condition)
    (display condition (terminal-output))
    value-of-default-warning-handler))  ; Return to the signaller.

(define value-of-default-warning-handler
        (undefined-value "default warning handler"))

;;;;; Serious Conditions

(define-predicate serious-condition?)

(define (displaying-serious-condition port thunk)
  (catch abort
    (with-condition-handler
        (lambda (c)
          (if (serious-condition? c)
              (with-condition-handler (lambda (c)   ; Total lossage.
                                        (ignore c)
                                        (abort))
                (lambda ()
                  ;; Probably shouldn't use FORMAT here.
                  (format port '("~&"
                                 "**** Serious condition while"
                                 " displaying serious condition!~%"
                                 "****     ~S~%")
                          c)
                  (abort)))
              c))                       ; Decline to handle: resignal.
      thunk)))

(define-simple-switch standard-serious-condition-handler
  procedure?
  (lambda (condition)
    (display condition (terminal-output))
    (fatal-error)))

(define-predicate error?)

(define (make-formatted-error type-prefix fmt args)
  (object nil
    ((condition?         self) '#t)
    ((serious-condition? self) '#t)
    ((error?             self) '#t)
    ((display self port)
     (displaying-serious-condition port
       (lambda ()
         (standard-display-condition port "** " type-prefix
                                     fmt args))))))

(define (error fmt . args)
  (signal-condition (make-formatted-error "Error" fmt args)))

(define (ignorable-error restarter-displayer fmt . args)
  (signal-ignorably restarter-displayer
                    (make-formatted-error "Error" fmt args)))

;;;;;; Datum Errors

(define-predicate datum-error?)
(define-operation (error-datum condition))

(define-integrable (make-formatted-datum-error predicate datum
                                               type-prefix fmt args)
  (object nil
    ((condition?         self) '#t)
    ((serious-condition? self) '#t)
    ((error?             self) '#t)
    ((datum-error?       self) '#t)
    ((error-datum        self) datum)
    ((predicate          self) '#t)
    ((display self port)
     (displaying-serious-condition port
       (lambda ()
         (standard-display-condition port "** " type-prefix
                                     fmt args))))))

(define-predicate syntax-error?)

(define (make-formatted-syntax-error form fmt args)
  (make-formatted-datum-error syntax-error? form
                              "Syntax error" fmt args))

(define (syntax-error form fmt . args)
  (signal-condition (make-formatted-syntax-error form fmt args)))

(define (substitutable-syntax-error form fmt . args)
  (signal-substitutably "Substitute a form to use instead."
                        (lambda ()
                          (prompt-for-expression "form to substitute"))
                        (make-formatted-syntax-error form fmt args)))

;;;;;;; Argument Errors

(define-predicate wrong-type-argument-error?)

(define (make-wrong-type-argument-error operator operand argument type)
  (make-formatted-datum-error wrong-type-argument-error? argument
                              "Error"
                              '("wrong type argument"
                                "~%~S"
                                "~%as operand ~A of ~S"
                                "~%expected ~A")
                              (list argument operand
                                    (or (identification operator)
                                        operator)
                                    type)))

(define (wrong-type-argument-error operator operand argument type)
  (signal-condition
   (make-wrong-type-argument-error operator operand argument type)))

(define (substitutable-wrong-type-argument-error operator operand
                                                 argument type)
  (signal-substitutably
   "Substitute a different value for the argument."
   (lambda ()
     (prompt-for-evaluated-expression "value to substitute"))
   (make-wrong-type-argument-error operator operand argument type)))

(define-integrable (check-type pred arg caller operand type)
  (if (pred arg)
      arg
      ;; Punt to non-integrated code elsewhere.
      (*check-type-error pred arg caller operand type)))

(define (*check-type-error pred arg caller operand type)
  (iterate loop ((arg arg))
    (let ((new (substitutable-wrong-type-argument-error caller operand
                                                        arg type)))
      (if (pred new)
          new
          (loop new)))))

(define-predicate argument-out-of-range-error?)

(define (make-argument-out-of-range-error operator operand
                                          argument lower upper)
  (make-formatted-datum-error argument-out-of-range-error? argument
                              "Error"
                              '("argument out of range~%"
                                "~S~%"
                                "as operand ~A of ~S~%"
                                "expected range was [~S,~S)")
                              (list arg operand
                                    (or (identification operator)
                                        operator)
                                    lower upper)))

(define (argument-out-of-range-error operator operand
                                     argment lower upper)
  (signal-condition
   (make-argument-out-of-range-error operator operand
                                     argument lower upper)))

;;; This is a bit of a mouthful of a name.  I wonder whether it would
;;; be better to eschew this (and ARGUMENT-OUT-OF-RANGE-ERROR)
;;; altogether and to provide only MAKE-ARGUMENT-OUT-OF-RANGE-ERROR,
;;; possibly under the name ARGUMENT-OUT-OF-RANGE-ERROR; then callers
;;; would pass the condition to SIGNAL-CONDITION, SIGNAL-SUBSTITUTABLY,
;;; &c. themselves.  E.g.:
;;;
;;;   (signal-substitutably "Use a different index."
;;;       (lambda () (prompt-for-evaluated-expression "index"))
;;;     (argument-out-of-range-error 'FOO 3 i 0 (vector-length v)))

(define (substitutable-argument-out-of-range-error operator operand
                                                   argument low high)
  (signal-substitutably
   "Substitute a different value for the argument."
   (lambda ()
     (prompt-for-evaluated-expression "value to substitute"))
   (make-argument-out-of-range-error operator operand argument
                                     low high)))

(define-integrable (check-range lower upper arg caller operand)
  (if (and (<= lower arg)
           (< arg upper))
      arg
      (*check-range-error lower upper arg caller operand)))

(define (*check-range-error lower upper arg caller operand)
  (iterate loop ((arg arg))
    (let ((new (argument-out-of-range-error caller operand arg
                                            lower upper)))
      (if (and (<= lower new) (< new upper))
          new
          (loop new)))))

;;;; Restarting

(lset *bound-restarters* '())

(define-predicate restarter?)
(define-predicate interactive-restarter?)
(define-operation (restart-interactively restarter))
(define-operation (restarter-active? restarter condition))

(define (with-restarter restarter thunk)
  (bind ((*bound-restarters* (cons restarter *bound-restarters*)))
    (thunk)))

(define (selected-restarters predicate . condition)
  (let ((predicate (restarter-predicate predicate condition
                                        selected-restarters 2)))
    (iterate loop ((bound *bound-restarters*)
                   (selected '()))
      (if (null? bound)
          (reverse! selected)
          (loop (cdr bound)
                (let ((restarter (car bound)))
                  (if (predicate restarter)
                      (cons restarter selected)
                      selected)))))))

(define (named-restarters name . condition)
  (apply selected-restarters
         (if (list? name)
             (lambda (r) (memq? (identification r) name))
             (lambda (r) (eq? (identification r) name)))
         condition))

(define (find-restarter predicate . condition)
  (let ((predicate (restarter-predicate predicate condition
                                        find-restarter 2)))
    (iterate loop ((restarters *bound-restarters*))
      (cond ((null? restarters)
             '#f)
            ((predicate (car restarters))
             (car restarters))
            (else
             (loop (cdr restarters)))))))

(define (restarter-predicate predicate condition-option
                             caller max-arity)
  ;++ check arity
  (if (null? condition-option)
      predicate
      (let ((condition (car condition-option)))
        (lambda (restarter)
          (and (predicate restarter)
               (restarter-active? restarter condition))))))

(define-predicate restart/ignore?)
(define-predicate restart/abort?)
(define-predicate restart/retry?)
(define-predicate restart/use-value?)
(define-predicate restart/store-value?)

;;;;; Standard Restarters

(define (with-exiting-restarter pred id displayer conditions receiver)
  (catch throw
    (let ((restarter (make-exiting-restarter throw pred id displayer
                                             conditions)))
      (with-restarter restarter
        (lambda ()
          (receiver restarter))))))

(define (make-exiting-restarter throw pred id displayer conditions)
  (let ((displayer
         (displayer-argument displayer make-exiting-restarter 3))
        (active? (active-predicate conditions
                                   make-exiting-restarter 4)))
    (object (lambda () (throw))         ; Enforce arity of zero.
      ((restarter? self) '#t)
      ((pred self) '#t)
      ((interactive-restarter? self) '#t)
      ((restart-interactively self) (throw))
      ((restarter-active? self condition) (active? condition))
      ((display self port) (displayer self port))
      ((print-type-string self) "Restarter")
      ((identification self) id))))

(define (with-value-substitution-restarter displayer substitute-reader
            conditions
          receiver)
  (catch throw
    (let ((restarter
           (make-value-substitution-restarter throw substitute-reader
                                              displayer
                                              conditions)))
      (with-restarter restarter
        (lambda ()
          (receiver restarter))))))

(define (make-value-substitution-restarter throw substitute-reader
                                           displayer
                                           conditions)
  (let ((displayer
         (displayer-argument displayer
                             make-value-substitution-restarter
                             2))
        (active? (active-predicate conditions
                                   make-value-substitution-restarter
                                   3)))
    (object (lambda (value)             ; Enforce arity of one.
              (throw value))
      ((restarter? self) '#t)
      ((restart/use-value? self) '#t)
      ((interactive-restarter? self) '#t)
      ((restart-interactively self) (throw (substitute-reader)))
      ((restarter-active? self condition) (active? condition))
      ((display self port) (displayer self port))
      ((print-type-string self) "Restarter")
      ((identification self) 'use-value))))

(define (active-predicate conditions caller operand)
  ;++ What about joins?
  (cond ((or (null? conditions) (not conditions))
         ;++ Should this be #T or #F?
         (lambda (condition) (ignore condition) '#t))
        ((list? conditions)
         (lambda (condition) (memq? condition conditions)))
        (else
         (lambda (condition) (eq? condition conditions)))))

(define (displayer-argument displayer operator operand)
  (iterate loop ((displayer displayer))
    (cond ((procedure? displayer) displayer)
          ((string?    displayer) (lambda (obj port)
                                    (ignore obj)
                                    (write-string port displayer)))
          (else (loop (wrong-type-argument-error
                       displayer operator operand
                       "string or binary procedure"))))))

#|

;;; Totally contrived example of the condition system:

(define (read-eval-print-loop)
  (with-exiting-restarter restart/abort? 'exit-repl
      "Exit the REPL." nil        ; no associated condition(s)
    (lambda (r)
      (ignore r)
      (iterate level-loop ((level 0))
        (with-condition-handler
            (lambda (c)
              (display c (repl-output))
              (force-output (repl-output))
              (if (serious-condition? c)
                  (level-loop (fx+ level 1)))
              c)
          (lambda ()
            (iterate loop ()
              (with-exiting-restarter restart/abort?
                  'return-to-repl
                  (if (fx-zero? level)
                      "Return to the top level."
                      (format nil "Return to REPL level ~D."
                              level))
                  nil                   ; no associated conditions
                (lambda (r)
                  (ignore r)
                  (write-string (repl-output) ((repl-prompt) level))
                  (force-output (repl-output))
                  (let* ((expression    ; Yes, this is contrived...
                          (with-value-substitution-restarter
                              "Evaluate another expression."
                              (lambda ()
                                (prompt-for-expression
                                 "expression to evaluate"))
                              nil       ; No associated condition(s)
                            (lambda (r)
                              (ignore r)
                              (read (repl-input)))))
                         (value (eval expression (repl-env))))
                    (if (not (repl-wont-print? value))
                        (let ((out (repl-output)))
                          (print value out)
                          (newline out)
                          (force-output out))))))
              (loop))))))))

|#

;;; A useful interactive utility.  The ordering of output and selection
;;; is designed to be maximally convenient:
;;;
;;;   - More nested restarters are listed with higher numbers, so you
;;;     can consistently do (RESTART 0) to exit the REPL, (RESTART 1)
;;;     to return to the top level, &c., provided you remain in the
;;;     same interactive environment.
;;;   - The outermost restarters are listed first, so what you see
;;;     closest to the prompt when you're done is the most relevant to
;;;     the condition, while far above is the least relevant.
;;;   - (RESTART n) corresponds with the nth term of (RESTART) output.
;;;   - When restarting by name, the innermost restarter with the given
;;;     name is chosen, so you don't need to grovel down to find the
;;;     index of the restarter except in less common cases: usually you
;;;     will either want to abort to the top level, for which you can
;;;     use a small, fixed number, or use the most immediately relevant
;;;     restarter, as with (RESTART 'USE-VALUE) or something.

(define (restart . arg)
  (let ((restarters (selected-restarters interactive-restarter?))
        (out (repl-output)))
    (if (null? arg)
        (show-restarters restarters out)
        (invoke-restarter (car arg) restarters out))))

(define (show-restarters restarters out)
  (iterate loop ((rs (reverse! restarters)) (i 0))
    (cond ((pair? rs)
           (format out " ~D. " i)
           (let ((r (car rs)))
             (cond ((identification r)
                    => (lambda (id)
                         (format out "[~S] " id))))
             (display r out))
           (newline out)
           (loop (cdr rs) (fx+ i 1)))
          (else repl-wont-print))))

(define (invoke-restarter id restarters out)
  (cond ((and (nonnegative-fixnum? id)
              (fx< id (length restarters)))
         (restart-interactively
          (nth (reverse! restarters) id)))
        ((cond ((procedure? id)
                (any (lambda (r) (and (id r) r))
                     restarters))
               ((symbol? id)
                (any (lambda (r)
                       (and (eq? (identification r) id)
                            r))
                     restarters))
               (else '#f))
         => restart-interactively)
        (else
         (format out "Illegal restarter index ~S.~%" id)
         repl-wont-print)))