;;; 27.5 Presentation Translator Utilities

(in-package :clim-internals)

(defun find-presentation-translator (translator-name command-table
                                     &key (errorp t))
  (let* ((command-table (find-command-table command-table))
         (translator-table (presentation-translators command-table))
         (translator (gethash translator-name (translators translator-table))))
    (if translator
        (values translator command-table)
        (when errorp
          (error 'command-not-accessible)))))

(defun add-presentation-translator-to-command-table
    (command-table translator &key (errorp t))
  ;; This version of add-presentation-translator-to-command-table takes
  ;; a translator object as argument instead of a translator name.
  (let ((command-table (find-command-table command-table)))
    (multiple-value-bind (old table)
        (find-presentation-translator (name translator) command-table
                                      :errorp nil)
      (declare (ignore table))
      (when (and old errorp)
        (error 'command-already-present))
      ;; add-translator will remove an old translator
      (add-translator (presentation-translators command-table) translator))))

(defun remove-presentation-translator-from-command-table
    (command-table translator-name &key (errorp t))
  (multiple-value-bind (translator table)
      (find-presentation-translator translator-name command-table :errorp nil)
    (if (and translator table)
        (with-accessors ((translators translators)
                         (simple-type-translators simple-type-translators))
            (presentation-translators table)
          (setf (gethash (presentation-type-name (from-type translator))
                         simple-type-translators)
                (remove translator
                        (gethash (presentation-type-name
                                  (from-type translator))
                                 simple-type-translators)))
          (remhash (name translator) translators))
        (when errorp
          (error 'command-not-present)))))

(defun map-over-command-table-translators (function command-table
                                           &key (inherited t))
  (let ((command-table (find-command-table command-table)))
    (flet ((map-func (table)
             (maphash #'(lambda (key val)
                          (declare (ignore key))
                          (funcall function val))
                      (translators (presentation-translators table)))))
      (if inherited
          (apply-with-command-table-inheritance #'map-func command-table)
          (map-func command-table)))))