Composition with custom composers

Here is an improved version of composition, with less unnecessary η-expansion, flexible user-defined operators (macros, actually), and a higher documentation-to-implementation ratio:

(defun eta (sym)
  "Eta-expand SYM to a lambda-expression, unless it's in CL and therefore unlikely to change."
  (if (eq (symbol-package sym) (find-package "CL"))
    `#',sym
    `(lambda (&rest args) (apply #',sym args))))

(defmacro composition (body)
  "Defines a function in an abbreviated combinator language.
   A symbol names a function. A list is a composition of functions.
   Normally functions are composed with B* (or H is there are more than two),
   but if the first one is a symbol with a COMPOSER property, that property
   is used instead - it may be a symbol to prefix, or a function returning
   a replacement form.
   For example, (COMPOSITION (= CAR 2)) expands to (H #'= #'CAR (K 2)),
   which is equivalent to (LAMBDA (x) (= (CAR X) 2)).
   See also the SAMEFRINGE and FACTORIAL examples."
  (labels ((translate (term)
             (typecase term
               (symbol (eta term))
               (cons (let ((composer (and (symbolp (car term))
                                          (get (car term) 'composer))))
                       (typecase composer
                         (null (cons (if (cddr term) 'h 'b*)
                                     (mapcar #'translate term)))
                         (symbol (cons composer (mapcar #'translate (cdr term))))
                         (function (funcall composer term)))))
               (t `(k ',term)))))
    (translate body)))

;;;Some composer definitions:
(setf (get 'and 'composer) 'hand)
(setf (get 'or 'composer) 'hor)
(setf (get 'if 'composer) 'hif)
(setf (get 'funcall 'composer) 'funcall)
(setf (get 'quote 'composer) (lambda (term) `(k ,term)))
(setf (get 'while 'composer) 'while)

(Why is the null branch of the typecase first instead of last? Because nil is a symbol in CL, so it can't go after the symbol clause. I've had the same problem before, because of this ugly bit of design.)

The new composition can handle the clearer version of rotate-right:

(defcomposition rotate-right
  (while (consp car) (cons caar (cons cdar cdr))))

...as well as a slightly more complex standard example:

(defcomposition next (if oddp (+ (* 3 identity) 1) (/ identity 2)))

(defcomposition iter (reverse ((while (> car 1) (cons (next car) identity))
                               list)))

(defcomposition try (format 't "~&~S: ~S" identity (1- (length iter))))

composition is not too awkward to program in, at least for simple functions. On the other hand, I wanted to add (loop for i from 1 to n do (try i)), but there is no good way to say it. Iteration in general is often hard to write with combinators. (Actually it's often messy in any style, because complex loops are common and diverse, and they aren't easily composed from smaller parts.) Composition suffers from its inability to handle lexical nesting or multiple return values. Both of these features could be straightforwardly added with suitable composer definitions.

While I was working on composition, I had a bug: I wrote (symbolp term) instead of (symbolp (car term)). SBCL's type inference happily concluded that composer was always nil, and spit out six "deleting unreachable code" warnings (excuse me, "notes") like this:

;     (CONS COMPOSER (MAPCAR #'TRANSLATE (CDR TERM)))
; 
; note: deleting unreachable code

As it happened, I found the problem right away once I knew it existed, but it could easily have been a mystery. Program checkers are nice and all, but they're more useful when their output is comprehensible.