;;;
;;; KIF: Kaz Kylheku's response to Paul Graham's "anaphoric if" macro.
;;; January 2015
;;;

;;;
;;; Consider the sentence: "If the square of x exceeds 25,
;;; then double it, otherwise halve it". Most English speakers
;;; will identify "it" either with x, or with "the square of x".
;;; Those who are intelligent will note that there is no need for "it"
;;; for the variable "x", since it can always be referred to as "x" without
;;; a pronoun.
;;;
;;; Paul Grapham's silly identifies "it" with the main boolean
;;; conditional "greater than" itself, which is not very often useful,
;;; and also doesn't correspond with linguistic intuition regarding
;;; anaphoric pronouns!
;;;
;;; A proper anaphoric if macro must work harder: it must analyze
;;; the syntax of the test expression, and intelligently bind "it"
;;; to an interesting constituent, rather than to the expression itself.
;;;
;;; KIF is a proposal in this direction. It could be smarter and have
;;; more features.
;;;
;;; Kif works like this:
;;;
;;; (kif test then [ else ])
;;;
;;;   1. If test is an atom, or an operator with no arguments,
;;;      then the value of test is "it": (let ((it test)) (if it then else))
;;;
;;;   2. If test matches the pattern (not X) or (null X)
;;;      the whole thing is transformed to (kif X else then)
;;;      and processed recursively.
;;;
;;;   Otherwise test must be of the form (op {arg}+)
;;;
;;;   3. If op is not a global function, then error, because it
;;;      is probably an operator. (Or a local function, but we don't
;;;      have the environment access at macro time to delve into that,
;;;      code walking is needed.)
;;;
;;;   Define a "candidate expression" be one that is neither a constant
;;;   nor a symbol.
;;;
;;;   4. If op has more than one argument which is a candidate
;;;      expression, then an ambiguous situation results: error.
;;;
;;;   5. If op has exactly one argument which is candidate
;;;      expression, then the value of that expression is "it".
;;;
;;;   6. Otherwise if op has no candidate arguments, then the leftmost
;;;      one is "it".
;;;

(eval-when (:compile-toplevel :load-toplevel :execute)
  ;;
  ;; Macro helper: performs steps 3 through 6 of the above
  ;; description, returning several values:
  ;; - a list of temporary symbols (gensyms)
  ;; - a list of forms which can be used to initialize these
  ;;   symbols in a let-like construct
  ;; - an expression equivalent to expr, but which requires
  ;;   the above bindings to be established.
  ;; - a symbol, which one of the gensyms in the first returned value.
  ;;   If this symbol is bound to its init form, that symbols's
  ;;   value then is the anaphoric value which can be bound to the "it"
  ;;   variable.
  ;;
  (defun anaphorize (construct expr env)
    (flet ((candidate-p (expr)
             (not (or (constantp expr env) (symbolp expr)))))
      (let* ((sym (first expr))
             (args (rest expr))
             (n-candidate-args (count-if #'candidate-p args))
             (pos-candidate (or (position-if #'candidate-p args) 0)))
        (unless (fboundp sym)
          (error "~a: only works with global functions." construct))
        (when (> n-candidate-args 1)
          (error "~a ambiguous situation: not clear what can be \"it\"."
                 construct))
        (let* ((temps (loop for x in args collecting (gensym)))
               (it-temp (nth pos-candidate temps)))
          (values temps args `(,sym ,@temps) it-temp))))))

(defmacro kif (test then &optional else &environment env)
  (cond
    ((or (atom test) (null (cdr test))) `(let ((it ,test))
                                           (if it ,then ,else)))
    ((member (first test) '(not null)) `(kif ,(second test) ,else ,then))
    (t (multiple-value-bind (temps args form it-temp)
                            (anaphorize 'kif test env)
         `(let* (,@(mapcar #'list temps args) (it ,it-temp))
            (if ,form ,then ,else))))))

(defmacro kwhile (test &rest forms)
  (let ((label (gensym "again-")))
    `(block nil
       (tagbody ,label
         (kif ,test (progn ,@forms (go ,label) (return nil)))))))

;;;
;;; Test cases
;;;

(defmacro error-to-sym (expr)
  `(handler-case ,expr
     (error (cond) :error)))

;; test framework for KIF uses KIF!
(defmacro test (&environment env expr expected)
  (handler-case
    (let ((expr-expn (macroexpand expr env)))
      `(kif (not (equal (error-to-sym ,expr-expn) ',expected))
         (error "test case ~s failed: produced ~s; expected ~s"
                ',expr it ',expected)))
    (error (cond)
      (unless (eq expected :error)
        (error "test case ~s failed to expand: expected is ~s" expr expected)))))

;; "it" is (+ 2 2)
(test (kif (> (+ 2 2) 0) (* it 2))
      8)

;; "it" is (* x x)
(test (let ((x 7))
        (kif (>= (* x x) 49)
          (sqrt it)))
      7)

;; "it" is (* x x)
(test (let ((x 7))
        (kif (>= (* x x) 49)
          (sqrt it)))
      7)

;; ambiguous: is "it" x or is "it" y?
(test (kif (> x y) (print it)) :error)

;; "it" is (+ 3 (* 2 x))
(test (let ((x 5))
        (kif (< 0 (+ 3 (* 2 x)) 20) (* 100 it)))
      1300)

;; "it" is (length '(a b c d))
;; Intuition: it" could also be '(a b c d)
;; TODO: deal specially with chains of unary functions.
;; How about it = (length ...), itt = '(a b c d)
(test (kif (not (oddp (length '(a b c d)))) it)
      4)