Define-prop and get-prop, chez scheme-style, for Racket

file.rkt

#lang racket
;; License: creative commons zero-1.0

(module props '#%kernel
  (#%provide (for-syntax current-props)
             define-prop
             get-prop)
  
  (#%require racket/private/small-scheme
             syntax/id-table
             (for-syntax '#%kernel
                         racket/private/qq-and-or
                         racket/private/stx))

  ;; This is a poor man's syntax parameter. Since the implementation of
  ;; racket/stxparam depends on syntax-case, and we want to add current-props to
  ;; syntax-case, we cannot use syntax parameters, lest we create a cyclic
  ;; dependency. Instead, we implement here a simplified "syntax parameter".
  ;  Like racket/stxparam, it relies on nested bindings of the same identifier,
  ;; and on syntax-local-get-shadower to access the most nested binding.

  ;; Since define/with-syntax and define/syntax-parse need to add new ids to
  ;; the list, they redefine current-props-param, shadowing the outer binding.
  ;; Unfortunately, if a let form contains two uses of define/with-syntax, this
  ;; would result in two redefinitions of current-props-param, which would cause
  ;; a "duplicate definition" error. Instead of shadowing the outer bindings, we
  ;; therefore store the list of bound syntax pattern variables in a new, fresh
  ;; identifier. When accessing the list, (current-props) then checks all such
  ;; identifiers. The identifiers have the form current-props-paramNNN and are
  ;; numbered sequentially, each new "shadowing" identifier using the number
  ;; following the latest visible identifier.
  ;; When it is safe to shadow identifiers (i.e. for with-props, but not for
  ;; define-prop), current-props-index-lower-bound is also shadowed.
  ;; When current-props-index-lower-bound is bound, it contains the index of the
  ;; latest current-props-paramNNN at that point.
  ;; When accessing the latest current-props-paramNNN, a dichotomy search is
  ;; performed between current-props-index-lower-bound and an upper bound
  ;; computed by trying to access lower-bound + 2ᵏ, with increasing values of k,
  ;; until an unbound identifier is found.

  ;; (poor-man-parameterof exact-nonnegative-integer?)
  (define-syntaxes (current-props-index-lower-bound) 0)
  
  (begin-for-syntax
    ;; (-> any/c (or/c (listof syntax?) #f))
    (define-values (syntax*->list)
      (λ (stxlist)
        (syntax->list (datum->syntax #f stxlist))))
    
    ;; (-> identifier? (or/c #f (listof identifier?)))
    (define-values (try-current-props)
      (λ (id)
        (syntax-local-value
         (syntax-local-get-shadower id
                                    #t)
         ;; Default value if we are outside of any with-props.
         (λ () #f))))

    ;; (-> exact-nonnegative-integer? identifier?)
    (define-values (nth-current-props-id)
      (λ (n)
        (syntax-local-introduce
         (datum->syntax (quote-syntax here)
                        (string->symbol
                         (format "current-props-param~a" n))))))
    
    ;; (-> exact-nonnegative-integer? (or/c #f (listof identifier?)))
    (define-values (try-nth-current-props)
      (λ (n)
        (try-current-props (nth-current-props-id n))))

    ;; (-> exact-nonnegative-integer? exact-nonnegative-integer?
    ;;     exact-nonnegative-integer?)
    ;; Doubles the value of n until (+ start n) is not a valid index
    ;; in the current-props-param pseudo-array
    (define-values (double-max)
      (λ (start n)
        (if (try-nth-current-props (+ start n))
            (double-max start (* n 2))
            (+ start n))))


    ;; (-> exact-nonnegative-integer? exact-nonnegative-integer?
    ;;     exact-nonnegative-integer?)
    ;; Preconditions: upper > lower ∧ upper - lower = 2ᵏ ∧ k ∈ ℕ
    ;; Returns the last valid index in the current-props-param pseudo-array,
    ;; by dichotomy between 
    (define-values (dichotomy)
      (λ (lower upper)
        (if (= (- upper lower) 1)
            (if (try-nth-current-props upper)
                upper ;; Technically not possible, still included for safety.
                lower)
            (let ([mid (/ (+ upper lower) 2)])
              (if (try-nth-current-props mid)
                  (dichotomy mid upper)
                  (dichotomy lower mid))))))

    ;; (-> exact-nonnegative-integer?)
    (define-values (find-last-current-props)
      (λ ()
        (let ([lower-bound (syntax-local-value
                            (syntax-local-get-shadower
                             (syntax-local-introduce
                              (quote-syntax current-props-index-lower-bound))
                             #t))])
          (if (not (try-nth-current-props (+ lower-bound 1)))
              ;; Short path for the common case where there are no uses
              ;; of define/with-syntax or define/syntax-parse in the most nested
              ;; syntax-case, with-syntax or syntax-parse
              lower-bound
              ;; Find an upper bound by repeatedly doubling an offset (starting
              ;; with 1) from the lower bound, then perform a dichotomy between
              ;; these two bounds.
              (dichotomy lower-bound
                         (double-max lower-bound 1))))))

    ;; (-> (listof identifier?))
    (define-values (current-props)
      (λ ()
        (try-nth-current-props (find-last-current-props)))))

  (define-values (set-prop-function)
    (lambda (h id p v)
      (let* ([h0 (or h (make-immutable-free-id-table))]
             [h1 (free-id-table-ref h0 id #f)])
        (if h1
            (free-id-table-set h0 id (hash-set h1 p v))
            (free-id-table-set h0 id (hash p v))))))
  
  (define-values (get-prop-function)
    (lambda (h id p not-found-value)
      (let* ([h1 (free-id-table-ref h id #f)])
        (if h1
            (hash-ref h1 p not-found-value)
            not-found-value))))

  (define-syntaxes (define-prop)
    (lambda (stx)
      (if (and (stx-pair? stx)
               (stx-pair? (stx-cdr stx))
               (identifier? (stx-car (stx-cdr stx)))
               (stx-pair? (stx-cdr (stx-cdr stx)))
               (identifier? (stx-car (stx-cdr (stx-cdr stx))))
               (stx-pair? (stx-cdr (stx-cdr (stx-cdr stx))))
               (stx-null? (stx-cdr (stx-cdr (stx-cdr (stx-cdr stx))))))
          (void)
          (raise-syntax-error 'define-prop "bad syntax" stx))
      (let* ([id (stx-car (stx-cdr stx))]
             [p (stx-car (stx-cdr (stx-cdr stx)))]
             [v (stx-car (stx-cdr (stx-cdr (stx-cdr stx))))]
             [props (reverse (syntax*->list (stx-cdr stx)))]
             [old-props-index (find-last-current-props)]
             [binding (syntax-local-identifier-as-binding
                       (nth-current-props-id (+ old-props-index 1)))]
             [old (try-nth-current-props old-props-index)])
        (datum->syntax
         (quote-syntax here)
         `(begin
            (define-values (tmp)
              (set-prop-function ,(if old
                                      (syntax-local-introduce old)
                                      (quote-syntax #f))
                                 (quote-syntax ,id)
                                 ',p
                                 ,v))
            (define-syntaxes (,binding) (quote-syntax tmp)))))))

  (define-syntaxes (get-prop)
    (lambda (stx)
      (if (and (stx-pair? stx)
               (stx-pair? (stx-cdr stx))
               (identifier? (stx-car (stx-cdr stx)))
               (stx-pair? (stx-cdr (stx-cdr stx)))
               (identifier? (stx-car (stx-cdr (stx-cdr stx))))
               (or (stx-null? (stx-cdr (stx-cdr (stx-cdr stx))))
                   (and
                    (stx-pair? (stx-cdr (stx-cdr (stx-cdr stx))))
                    (stx-null? (stx-cdr (stx-cdr (stx-cdr (stx-cdr stx))))))))
          (void)
          (raise-syntax-error 'with-props "bad syntax" stx))
      (let* ([id (stx-car (stx-cdr stx))]
             [p (stx-car (stx-cdr (stx-cdr stx)))]
             [not-found-value (if (stx-null? (stx-cdr (stx-cdr (stx-cdr stx))))
                                  (quote-syntax #f)
                                  (stx-car (stx-cdr (stx-cdr (stx-cdr stx)))))]
             [old-props-index (find-last-current-props)]
             [old (try-nth-current-props old-props-index)])
        (datum->syntax
         (quote-syntax here)
         `(get-prop-function ,(if old
                                  (syntax-local-introduce old)
                                  (quote-syntax (hash)))
                             (quote-syntax ,id)
                             ',p
                             ,not-found-value))))))

(require 'props)
(define-prop + pa 'va1)
(define-prop + pb 'vb1)
(define-prop * pa 'ma1)

(get-prop + pa) ;; va1
(get-prop + pb) ;; vb1
(get-prop * pa) ;; ma1
(get-prop * pb) ;; #f (not defined)

(let ()
  (define-prop + pa 'va2)
  (define-prop * pb 'mb2)
  (list (get-prop + pa) ;; va2
        (get-prop + pb) ;; vb1
        (get-prop * pa) ;; ma1
        (get-prop * pb))) ;; mb2

(get-prop + pa) ;; va1
(get-prop + pb) ;; vb1
(get-prop * pa) ;; ma1
(get-prop * pb (λ () 'not-defined)) ;; 'not-defined