(defpackage "STRING=-SPECIALIZERS"
  (:use "CL" "SB-MOP" "SB-PCL" "STRING-CASE")
  (:lock t))

(in-package "STRING=-SPECIALIZERS")

(defclass string=-specializer (specializer)
  ((string :initform nil :reader string=-specializer-string :initarg :string)
   (direct-methods :initform nil :reader specializer-direct-methods)))

(defvar *string=-specializer-table*
  (make-hash-table :test 'equal))

(defun ensure-string=-specializer (string)
  (or (gethash string *string=-specializer-table*)
      (setf (gethash string *string=-specializer-table*)
            (make-instance 'string=-specializer :string string))))

(defclass magic-generic-function (standard-generic-function)
  ()
  (:metaclass funcallable-standard-class))

(defmethod compute-discriminating-function ((gf magic-generic-function))
  (lambda (prefix rest)
    (let* ((methods (generic-function-methods gf))
           (function (compiled-discriminating-function methods gf)))
      (set-funcallable-instance-function gf function)
      (funcall function prefix rest))))

(defun discriminating-function-lambda (methods gf)
  (let (clauses)
    (dolist (m methods)
      (let* ((specializer (car (method-specializers m)))
             (string (string=-specializer-string specializer))
             (form `(funcall ,(method-function m) (list prefix rest) nil)))
        (push `(,string ,form) clauses)))
    `(lambda (prefix rest)
      (declare (string prefix))
      (let ((prefix (coerce prefix '(simple-array character (*)))))
        (string-case (prefix :default (no-applicable-method ,gf prefix rest))
          ,@clauses)))))
  
(defun compiled-discriminating-function (methods gf)
  (compile nil (discriminating-function-lambda methods gf)))

(defmethod make-method-specializers-form 
    ((gf magic-generic-function) method names environment)
  ;; only works for lambda lists of the form ((string= string) t)
  `(list (ensure-string=-specializer ,(cadar names)) (find-class t)))

(defmethod add-direct-method ((specializer string=-specializer) method)
  (pushnew method (slot-value specializer 'direct-methods)))

(defmethod remove-direct-method ((specializer string=-specializer) method)
  (setf (slot-value specializer 'direct-methods)
        (remove method (slot-value specializer 'direct-methods))))

(defmethod unparse-specializer-using-class 
    ((gf magic-generic-function) (specializer string=-specializer))
  `(string= ,(string=-specializer-string specializer)))

(defmethod parse-specializer-using-class ((gf magic-generic-function) name)
  (typecase name
    ((eql t) (find-class t))
    ((cons (eql string=)) (ensure-string=-specializer (cadr name)))
    (specializer name)))

#|

(defgeneric frob (prefix rest)
  (:generic-function-class magic-generic-function))

(defmethod frob ((prefix (string= "httpd")) httpd-line)
  (string-upcase httpd-line))

(defmethod frob ((prefix (string= "exim")) exim-line)
  (when (search "sendmail" exim-line)
    (warn "Exim confusion: ~S" exim-line)))

|#