Boolean operator equivalence

boe.rkt

#lang racket

;;;; Compare boolean operators for equivalence
;;;
;;; The purpose of this was to see if I could write a reasonably hairy
;;; macro in Racket without the result being incomprehensible.  I can,
;;; although it is probably not very idiomatic Racket.

(require (for-syntax (only-in racket/syntax format-id
                              current-syntax-context wrong-syntax)))

(provide boe-report-failure?
         boolean-operators-equivalent?)

(module+ test
  ;; for raco test
  (require rackunit))

(module+ main
  ;; for racket boe.rkt
  (require macro-debugger/expand))

(define boe-report-failure? (make-parameter #f))

(define-syntax (boolean-operators-equivalent? stx)
  ;; Given the names of two boolean operators and a list of argument
  ;; names, expand to a form which tests that they are equivalent, by
  ;; evaluating the with arguments bound to all the combinations of #t
  ;; and #f, and also checking that they evaluate the same arguments
  ;; in each case.
  ;;
  (parameterize ([current-syntax-context stx])
    (syntax-case stx ()
      [(_ o1 o2 (v ...))
       (let* ([vars (syntax->list #'(v ...))]
              [nvars (length vars)])
         ;; This check could be a guard, but we need the bindings
         ;; anyway, so.
         (for ([var vars])
           (unless (identifier? var)
             (wrong-syntax var "not an identifier")))
         ;; vars is now a list of identifiers, and nvars is how many
         ;; there are.  We need to construct syntax for check
         ;; variables for each var and and operator, as well as
         ;; construct 2^n and a list of bit numbers.]  This is being
         ;; fairly fast and loose: it turns out that various things
         ;; get automagically converted into syntax objects, and I
         ;; have not cared about the context for numbers (what is
         ;; it?).  In general I am a bit confused about what the
         ;; context should be here, but it clearly should *not* be
         ;; stx.
         ;;
         (with-syntax ([(o1c ...) (for/list ([v vars])
                                    (format-id #'boe "~a-1-eval-count" v))]
                       [(o2c ...) (for/list ([v vars])
                                    (format-id #'boe "~a-2-eval-count" v))]
                       [2^n (expt 2 nvars)]
                       [(b ...) (for/list ([i nvars]) i)])
           ;; And now just write the pattern we want.  '...' is pretty
           ;; clever, it turns out
           #'(for/and ([c 2^n])
               (let ([v (bitwise-bit-set? c b)] ...)
                 (let ([o1c 0] ...)
                   (let ([o2c 0] ...)
                     (or (and (eq? (o1 (begin (set! o1c (+ o1c 1)) v) ...)
                                   (o2 (begin (set! o2c (+ o2c 1)) v) ...))
                              (= o1c o2c) ...)
                         (begin
                           (when (boe-report-failure?)
                             (eprintf "Not equivalent:~% ~a~% ~a~%"
                                      (list 'o1 `(,v ,o1c) ...)
                                      (list 'o2 `(,v ,o2c) ...)))
                           #f))))))))]
      [else
       (wrong-syntax #'else "expecting o1 o2 (a1 ...)")])))

(module+ test
  ;; Some basic tests
  (parameterize ([boe-report-failure? #t])

    (check-true
     (boolean-operators-equivalent? if if (test then else)))

    (define-syntax-rule (if/broken test then else)
      (or (and test then) else))

    (check-false
     (boolean-operators-equivalent? if if/broken (test then else)))

    (define-syntax-rule (if/working test then else)
      (let ([r test])
        (or (and r then)
            (and (not r) else))))

    (check-true
     (boolean-operators-equivalent? if if/working (test then else)))))

(module+ main
  ;; Running this as a script just prints some expansions (well, one
  ;; expansion).

  (define examples
    (list #'(boolean-operators-equivalent? if if/working (test then else))))

  (define macros (list #'boolean-operators-equivalent?))

  (for ([e examples])
    (pretty-write (syntax->datum e))
    (displayln "->")
    (pretty-write (syntax->datum (expand-only e macros)))))

See post about this.