;;; I think I should code the tricky headcase recursion 
;;; just once and return three values
;;;
;;; in (f x y)
;;; (f x y) is the whole list
;;; (x y) is the part list
;;; f is the function case
;;; x is the argument case
;;; and in (f x y . z), z is  the dotted case

(defun build3 (left-type left-bind left-dummy right-type right-bind right-dummy)
  (values (list 'cons left-type right-type)
          (cons left-bind right-bind)
          (append left-dummy right-dummy)))

(defun whole-list3(wl)
  (typecase wl
    (symbol ;at the top level a symbol names a type
     (let ((gs (gensym "ignore-type")))
       ;; typecase is happy to see an atomic type specifier
       (values wl ;not (eql wl)
               (list gs)
               (list gs))))
    (atom ;I cannot see this being useful
     (let ((gs (gensym "top-level-constant")))
       (values (list 'eql wl)
               gs
               (list gs))))
    (cons
     (multiple-value-call #'build3
       (function-case3 (car wl))
       (part-list3 (cdr wl))))))

(defun part-list3(pl)
  (typecase pl
    ;; recognise the end of a proper list as a special case
    ;; because we get a saner macroexpansion using null instead
    ;; of (eql nil) and more importantly destructuring-bind understands
    ;; proper lists so we can feed it nil not a gensym
    (null 
     (values 'null   ;the type of nil;
             'nil    ;destructing-bind accepts this as the empty list
             '())) ;so we don't generate a gensym
    (atom (dotted-case3 pl))
    (cons
     (multiple-value-call #'build3
       (argument-case3 (car pl))
       (part-list3 (cdr pl))))))

(defun function-case3(f)
  (typecase f
    (atom ;including symbols, which are constants in head position
     (let ((gs (gensym "ignore-head-position")))
       (values (list 'eql f)
               gs
               (list gs))))
    (cons
     (multiple-value-call #'build3
       (function-case3 (car f))
       (part-list3 (cdr f))))))

(defun gensym-for-constant3 (x)
  (let ((gs (gensym "ignore-constant")))
    (values (list 'eql x)
            gs
            (list gs))))

(defun argument-case3(x)
  (typecase x
    (symbol
     (if (constantp x)
         ;; We cannot bind a constant symbol
         (gensym-for-constant3 x)
         ;; the common case: a variable to be bound
         (values t ;variables match anything
                 x
                 '())))
    (atom ;Probably not useful
     (gensym-for-constant3 x))
    (cons
     (multiple-value-call #'build3
       (function-case3 (car x))
       (part-list3 (cdr x))))))
      
(defun dotted-case3 (dot)
  (check-type dot atom "terminal atom of a dotted list")
  ;; We have already special cased nil
  ;; we now proceed exactly as for the argument case
  ;; so we might as well just call it.
  (argument-case3 dot))

(defmacro headcase (form &body clauses)
  (let ((key (gensym)))
    `(let ((,key ,form))
      (etypecase ,key ,@(mapcar (build-operator-clause key) clauses)))))

(defun build-operator-clause (key)
  (lambda(clause)
    (cond ((symbolp (car clause)) ;a bare symbol names a type
           clause)
          ((eql (car clause) 'otherwise)
           ;; copy common-lisp:case to keep a consistent style
           (cons t (cdr clause)))
          (t (multiple-value-bind (type-tree bind-tree ignores)
                 (whole-list3 (car clause))
               (list type-tree
                     `(destructuring-bind ,bind-tree ,key
                        (declare (ignore ,@ignores))
                        ,@(cdr clause))))))))