Defining a key-function-based equality interface over the top of `gen:equal+hash`.

derived-equality-interface.rkt

#lang racket

; This code is in service of @countvajhula's Rhombus equality RRFI at
; https://github.com/countvajhula/rhombus-prototype/tree/master/rrfi
; and parts of it should probably be copied into the proof of concept in that
; repo.

(require racket/generic)
(require rackunit)

(provide
  gen:comparable
  comparable-key)



; Here's an mplementation of a `gen:comparable` interface for values whose
; `equal?` behavior compares them by extracting a key in a memoized way:


(define (make-memoizer func)
  (define semaphore (make-semaphore 1))
  (define results (make-ephemeron-hasheq))
  (lambda (arg)
    ; First, we try to get the memoized result without locking.
    (hash-ref results arg
      (thunk
        ; If that didn't work, we lock.
        (call-with-semaphore semaphore
          (thunk
            
            ; Now, we try again to get the memoized result just in case it
            ; showed up while we were waiting for the lock. If it didn't, we
            ; compute it ourselves and store it for future use.
            ;
            (hash-ref! results arg (thunk (func arg)))))))))


; We define an underlying `prop:proto-comparable` to serve as an implementation
; detail for `gen:comparable`. This way, we can use a guard procedure to
; generate a type tag we need for `equal-hash-code`, and we can bar users from
; directly calling the `gen:comparable` `comparable-key` method to spy on an
; opaque comparable value's implementation details.
;
(define-values
  (prop:proto-comparable proto-comparable? proto-comparable-ref)
  (make-struct-type-property/generic 'proto-comparable
    (lambda (get-key info)
      
      ; We construct a type tag. We don't have access to the structure type
      ; property descriptor at this point, so we just create a gensym.
      ;
      (define struct-name (car info))
      (define type-tag (gensym struct-name))
      
      ; We then update the key function so that it bundles the type tag with the
      ; key. This way, different types which use the same key representation can
      ; still have different  `equal-hash-code` and `equal-secondary-hash-code`
      ; results.
      ;
      (lambda (value)
        (list type-tag (get-key value))))
    
    #:methods gen:equal+hash
    [
      (define (equal-proc a b recur)
        (recur
          (proto-comparable-memoize-key-chain a)
          (proto-comparable-memoize-key-chain b)))
      (define (hash-proc v recur)
        (recur (proto-comparable-memoize-key-chain v)))
      (define (hash2-proc v recur)
        (recur (proto-comparable-memoize-key-chain v)))
      ]))

(define (proto-comparable-compute-key-chain comparable)
  ((proto-comparable-ref comparable) comparable))

(define proto-comparable-memoize-key-chain
  (make-memoizer proto-comparable-compute-key-chain))

(define-generics comparable
  (comparable-key comparable)
  
  #:fast-defaults
  (
    [
      any/c
      (define (comparable-key comparable)
        (error 'comparable-key "can't invoke directly"))])
  
  ; Note that this use of `comparable-key` bypasses `#:fast-defaults` and uses
  ; the user's method implementation directly. This allows us to export the
  ; method `comparable-key` so that users can write implementations of it
  ; without weird scoping quirks, while disallowing users from calling
  ; `comparable-key` themselves.
  ;
  #:derive-property prop:proto-comparable comparable-key)



; Here's a demonstration:

(struct orderless-keyed-pair (first-key first-val second-key second-val)
  #:methods gen:comparable
  [
    (define (comparable-key comparable)
      (match-define
        (orderless-keyed-pair first-key first-val second-key second-val)
        comparable)
      (hash first-key first-val second-key second-val))
    ])

; This is exactly the same type definition again, just with a different name.
(struct orderless-keyed-pair-2 (first-key first-val second-key second-val)
  #:methods gen:comparable
  [
    (define (comparable-key comparable)
      (match-define
        (orderless-keyed-pair-2 first-key first-val second-key second-val)
        comparable)
      (hash first-key first-val second-key second-val))
    ])

(check-equal?
  (orderless-keyed-pair 'a 1 'b 2)
  (orderless-keyed-pair 'b 2 'a 1)
  "Two `comparable?` values compare according to the comparison on their keys.")

(check-not-equal?
  (orderless-keyed-pair 'a 1 'b 2)
  (orderless-keyed-pair 'b 3 'a 1)
  "Two `comparable?` values are sometimes not equal.")

(check-not-equal?
  (orderless-keyed-pair 'a 1 'b 2)
  (orderless-keyed-pair-2 'b 2 'a 1)
  "Values which differ only in terms of which of two identically defined `comparable?` types they're instances of are nevertheless distinct.")

(check-not-equal?
  (equal-hash-code (orderless-keyed-pair 'a 1 'b 2))
  (equal-hash-code (orderless-keyed-pair-2 'b 2 'a 1))
  "Values which differ only in terms of which of two identically defined `comparable?` types they're instances of are nevertheless distinct, even at the hash code level.")

(check-exn exn:fail?
  (thunk
    (comparable-key (orderless-keyed-pair 'a 1 'b 2)))
  "A user of a comparable value can't spy on its key.")