pico-muon.rkt

#lang racket/base

;; TODO: classifiers and views

(require racket/match)
(require racket/stxparam)
(require (for-syntax racket/base))

(define-syntax-parameter self
  (lambda (stx)
    (raise-syntax-error 'self "use of self outside `define-constructor` clause")))

(struct override-self (receiver args))

(define-syntax-rule (define-constructor (name field ...) [(pat ...) body ...] ...)
  (struct name (field ...) #:transparent
    #:property prop:procedure
    (lambda (direct-self . direct-args)
      (define-values (actual-self args)
        (match direct-args
          [(list (override-self indirect-self indirect-args))
           (values indirect-self indirect-args)]
          [_
           (values direct-self direct-args)]))
      (syntax-parameterize ((self (syntax-id-rules ()
                                    [(_ arg (... ...)) (actual-self arg (... ...))]
                                    [_ actual-self])))
        (match-let ([(name field ...) direct-self])
          (match args
            [(list pat ...) body ...]
            ...
            [_ (error 'name "does not understand: ~v" args)]))))))

(define (via behaviour receiver . args)
  (via* behaviour receiver args))

(define (via* behaviour receiver args)
  (behaviour (override-self receiver args)))

(define-constructor (fixed-retry delay-ms)
  [() (values (self 'get-delay) self)]
  [('get-delay) delay-ms])

(define-constructor (fixed-retry/margin delay-ms)
  [('get-delay) (+ delay-ms 10)]
  [(args ...) (via* (fixed-retry delay-ms) self args)])

(module+ main
  'data
  (fixed-retry 1000)
  (fixed-retry/margin 1000)
  'behaviour
  ((fixed-retry 1000))
  ((fixed-retry/margin 1000))
  )