extensible-structs.rkt

#lang racket/base

(require
  (for-syntax
    racket/base
    racket/match
    syntax/parse
    racket/syntax
    racket/struct-info))


;; parameter? -> (any -> any)
;; Wraps a parameter containing a function, so that after accessing the parameter once, the call to the parameter is cached.
(define (memo-wrap-param param)
  (let ([c (box #f)])
    (lambda args
      (cond
        [(unbox c) => (lambda (f) (apply f args))]
        [else (let ([f (param)])
                (begin
                  (set-box! c f)
                  (apply f args)))]))))

; Wrap a parameter containing a function with a normal function call interface.
; Optionally memoize the result.
(define (wrap-param param [memoize? #f])
  (if memoize?
      (memo-wrap-param param)
      (lambda args (apply (param) args))))

(begin-for-syntax
  ;; contains:
  ;; - a struct-info for the underlying struct.
  ;; - a syntax-transformer expected to generate the underlying struct constructor
  ;; - a 4-tuple of:
  ;;   1. the interposition point (parameter) for the constructor
  ;;   2. ... predicate
  ;;   3. a list of interposition points for the accessors
  ;;   4. ... for the mutators.
  (struct extensible-struct-info ([info #:mutable]
                                  transformer
                                  interposition-parameters)
    #:property prop:struct-info (lambda (c) (extensible-struct-info-info c))
    #:property prop:procedure (struct-field-index transformer))

  ;; struct-info? struct-info? -> syntax
  ;; Extend the phase 1 struct-info represented by base-info by extension-info, returning the code required to extend the
  ;; dynamic (phase 0) interposition points for the base struct.
  (define (do-extend-struct base-info extension-info)
    (match* (base-info extension-info)
      [((extensible-struct-info _ _ (list base-constr-param base-pred-param base-accessor-params base-mutator-params))
        (extensible-struct-info info _ (list extend-constr-param extend-pred-param extend-accessor-params extend-mutator-params)))
       (set-extensible-struct-info-info! base-info info)
       #`(begin
           (#,base-constr-param (#,extend-constr-param))
           (#,base-pred-param (#,extend-pred-param))
           #,@(for/list ([base (reverse base-accessor-params)]
                         [extend (reverse extend-accessor-params)])
                #`(#,base (#,extend)))
           #,@(for/list ([base (reverse base-mutator-params)]
                         [extend (reverse extend-mutator-params)])
                #`(#,base (#,extend))))]))

  (define (make-struct-interposition name-id _name-id)
    (match (extract-struct-info (syntax-local-value _name-id))
      [(list _ constr predicate accessors mutators _)

       (define-values (constr-param-id constr-transformer constr-defs)
         (make-constructor-interposition name-id constr))

       (define-values (pred-param-id pred-defs)
         (make-predicate-interposition name-id predicate))

       (define-values (accessor-param-ids accessor-defs)
         (make-accessor-interpositions name-id (filter values accessors) (struct-field-info-list (syntax-local-value _name-id))))

       (define-values (mutator-param-ids mutator-defs)
         (make-mutator-interpositions name-id (filter values mutators)))

       (with-syntax ([constr-param constr-param-id]
                     [pred-param pred-param-id]
                     [_name _name-id]
                     [name name-id]
                     [(accessor-params ...) accessor-param-ids]
                     [(mutator-params ...) mutator-param-ids])
         #`(begin
             #,@constr-defs
             #,@pred-defs
             #,@accessor-defs
             #,@mutator-defs
             (define-syntax name
               (extensible-struct-info
                 (extract-struct-info (syntax-local-value #'_name))
                 #,constr-transformer
                 (list
                   #'constr-param
                   #'pred-param
                   (list #'accessor-params ...)
                   (list #'mutator-params ...))))))]))

  (define (make-constructor-interposition stx-origin constr-id)
    (define constr-param-id (format-id stx-origin "param:~a" constr-id))
    (define __name (format-id stx-origin "__~a" constr-id))
    (values
      constr-param-id

      #`(lambda (stx)
          (syntax-parse stx
            [_:id #'#,__name]
            [(_ args (... ...))
             #'(#,__name args (... ...))]))

      #`((define #,constr-param-id (make-parameter #,constr-id))
         (define #,__name (wrap-param #,constr-param-id)))))

  (define (make-predicate-interposition name _predicate-id)
    (define predicate-param-id (format-id name "param:~a?" name))
    (define predicate-id (format-id name "~a?" name))
    (values
      predicate-param-id
      #`((define #,predicate-param-id (make-parameter #,_predicate-id))
         (define #,predicate-id (wrap-param #,predicate-param-id)))))

  (define (make-accessor-interpositions name accessor-ids fields)
    (define-values (accessor-param-ids accessors)
      (for/lists (l1 l2)
        ([field fields])
        (values
          (format-id name "param:~a-~a" name field)
          (format-id name "~a-~a" name field))))
    (values
      accessor-param-ids
      (with-syntax ([(accessor-param ...) accessor-param-ids]
                    [(accessor ...) accessors]
                    [(_accessor ...) accessor-ids])
        #`((define accessor-param (make-parameter _accessor))
           ...
           (define accessor (wrap-param accessor-param)) ...))))

  (define (make-mutator-interpositions name mutator-ids)
    (define-values (mutator-param-ids mutators)
      (for/lists (l1 l2)
        ([mutator mutator-ids])
        ;; assumes mutator id is of the form set-_name-field!
        ;; which, it should be, since we generated it that way
        (define mutator-substring (substring (symbol->string (syntax->datum mutator)) 5))
        (values
          (format-id name "param:set-~a" mutator-substring)
          (format-id name "set-~a" mutator-substring))))
    (values
      mutator-param-ids
      (with-syntax ([(mutator-param ...) mutator-param-ids]
                    [(mutator ...) mutators]
                    [(_mutator ...) mutator-ids])
        #`((define mutator-param (make-parameter _mutator))
           ...
           (define mutator (wrap-param mutator-param)) ...)))))

(define-syntax (extend-struct stx)
  (syntax-parse stx
    [(_ base:id extension:id)
     (do-extend-struct (syntax-local-value #'base) (syntax-local-value #'extension))]))

(define-syntax (do-struct-interposition stx)
  (syntax-parse stx
    [(_ name:id _name:id)
     (make-struct-interposition #'name #'_name)]))

(define-syntax (extensible-struct stx)
  (syntax-parse stx
    [(_ name:id options ...)
     #:with _name (format-id #'name "_~a" #'name)
     #`(begin
         (struct/derived #,stx _name options ... #:reflection-name 'name)
         ; in a macro to ensure struct, and therefore struct info, is defined before we call syntax-local-value on it.
         (do-struct-interposition name _name))]))

(module+ test
  (require
    rackunit
    racket/match
    racket/function)

  (extensible-struct foo (a b))

  ;; constructing and pattern matching works fine
  (check-equal?
    (match (foo 1 2)
      [(foo a b)
       (+ a b)])
    3)

  ;; mutators worked
  (extensible-struct bar ([a #:mutable]))
  (test-begin
    (let ([x (bar 1)])
      (check-not-exn (thunk (set-bar-a! x 1)))))

  (extensible-struct baz (a b))

  ;; extension works
  (extend-struct bar baz)

  ;; including with pattern matching.
  (check-equal?
    (match (bar 1 2)
      [(bar a b)
       (+ a b)])
    3)

  ; can't get mutation if you extend and change the mutability
  (test-begin
    (let ([x (bar 1 2)])
      (check-exn values (thunk (set-bar-a! x 1)))))

  ;; but extension with the same mutability works
  (extensible-struct biz ([a #:mutable]))
  (extensible-struct buz ([a #:mutable] b))
  (extend-struct biz buz)
  (test-begin
    (let ([x (biz 1 2)])
      (check-not-exn (thunk (set-biz-a! x 2)))
      (check-equal? (biz-a x) 2))))