zoz

;; curry*
;; like curry but will never fully apply and will instead make a
;; thunk
(define (curry* . args)
  (lambda rest-args
    (apply (first args)
           (append (rest args) rest-args))))

;; make-obj
;; make a classless singleton object
;; state:
;;;; list of pairs, each pair's car is the variable name and cdr is
;;;; the default value
;; methods:
;;;; list of pairs, each pair's car is the method name and cdr is
;;;; the implementation which must be a function that takes the
;;;; receiver and its state key (see below) and may take other
;;;; arguments
;; return value can be used as follows:
;; (retval 'method-name method-args...)
;; note that methods are in fact stored directly in the object and
;; not in a vtable; this is deliberate because objects can be
;; extended with new methods via the 'def pseudomethod
(define (make-obj state methods)
  (letrec
    ;; state-key
    ;; a unique symbol allowing access to the object's private
    ;; variables
    ;; will be passed to methods as second parameter after the
    ;; receiver itself and can be used as follows:
    ;; (receiver state-key 'variable-name) -- to get variable
    ;; (receiver state-key 'variable-name 'value) -- to set variable
    ([state-key (gensym)]
     [self
      (lambda (method . args)
        (cond
          [(eq? method state-key)
           (case (length args)
             [(0) state]
             [(1)
              (let ([found (assoc (first args) state)])
                (unless found
                  (raise-arguments-error state-key
                    "no such field"
                    "field name" (first args)))
                (cdr found))]
             [(2)
              (set! state
                (cons (cons (first args) (second args))
                      (remove (first args) state
                              (lambda (a b) (eq? a (car b))))))])]
          [(eq? method 'def)
           (unless (= (length args) 2)
             (raise-arguments-error state-key
               "wrong number of arguments to define a method"
               "arguments" args))
           (set! methods
             (cons (cons (first args) (second args))
                   (remove (first args) methods
                           (lambda (a b) (eq? a (car b))))))]
          [else
           (let ([found (assoc method methods)])
             (unless found
               (raise-arguments-error state-key
                 "no such method"
                 "method name" method))
             (unless (procedure-arity-includes?
                       (cdr found)
                       (+ 2 (length args)))
               (raise-arguments-error state-key
                 "unsupported number of arguments"
                 "method name" method
                 "arguments" args
                 "method arity" (procedure-arity (cdr found))))
             (apply (curry* (cdr found) self state-key) args))]))])
    self))

;; make-class
;; make a class, which is a classless singleton object that can make
;; other objects homogeneously according to a stored blueprint and
;; identify whether or not any given datum is an object that came
;; from it
;; state, methods: same as for make-obj, but affects instances
;; class-state, class-methods: affects the class itself instead
;; superclass:
;;;; if specified, objects created via the class currently
;;;; being defined will belong to both it and also the class given
;;;; by this parameter, and will follow the stored blueprints of
;;;; both, but such that any methods defined in the "subclass" (the
;;;; class currently being defined) will take priority over those
;;;; that were in the "superclass"
;; return value can be used as follows:
;; (retval 'superclass) -- returns the superclass or #f if none
;; (retval 'alloc) -- instantiates the class but doesn't call 'init
;; (retval 'new args...) -- instantiates the class and forwards the
;; rest of the args to a call to 'init if the class defines any such
;; method
;; (retval '? obj) -- returns whether the given object or other
;; datum is an object of this class
(define (make-class state methods
         #:class-state [class-state `()]
         #:class-methods [class-methods `()]
         #:superclass [superclass #f])
  (letrec
    ([class-key (gensym)]
     [init-proc
      (let ([found (assoc 'init methods)])
        (if found (cdr found) void))]
     [super-proc
      (lambda (self @ . args)
        (unless superclass
          (raise-arguments-error class-key
            "no superclass to call"
            "arguments" args))
        (apply
          (curry* (superclass 'init-proc)
                  self @) args))]
     [self
      (make-obj class-state
        (append class-methods
          `((init-proc .
             ,(lambda (self @) init-proc))
            (superclass .
             ,(lambda (self @) superclass))
            (alloc .
             ,(lambda (self @)
                (if superclass
                  (let ([retval (superclass 'alloc)])
                    (retval 'def class-key
                      (lambda (self @) @))
                    (retval 'def 'super super-proc)
                    (map (lambda (p)
                           (retval (retval class-key)
                                   (car p) (cdr p))) state)
                    (map (lambda (p)
                           (retval 'def (car p) (cdr p)))
                         methods)
                    retval)
                  (make-obj state
                    (append
                      `((,class-key . ,(lambda (self @) @))
                        (super . ,super-proc))
                      methods)))))
            (instance-init .
             ,(lambda (self @ obj . args)
                (unless (self '? obj)
                  (raise-arguments-error class-key
                    "can't initialize non-instance"
                    "non-instance" obj
                    "arguments" args))
                (let ([found (assoc 'init methods)])
                  (when found
                    (apply
                      (curry* (cdr found) obj (obj class-key))
                      args)))))
            (new .
             ,(lambda (self @ . args)
                (letrec
                  ([retval (self 'alloc)])
                  (apply
                    (curry* init-proc retval
                      (retval class-key))
                    args)
                  retval)))
            (? .
             ,(lambda (self @ obj)
                (with-handlers
                  ([exn:fail:contract? (lambda args #f)])
                  (obj class-key)
                  #t))))))]) self))

;; usage examples
(define counter
  (make-class `((a . 0))
    `((inc .
       ,(lambda (self @)
          (self @ 'a (add1 (self @ 'a)))
          (self @ 'a))))))
(define bidirectional-counter
  (make-class #:superclass counter `()
    `((dec .
       ,(lambda (self @)
          (self @ 'a (sub1 (self @ 'a)))
          (self @ 'a))))))
(define n (counter 'new))
(define m (bidirectional-counter 'new))
(display (counter '? n)) (newline) ;; #t
(display (counter '? m)) (newline) ;; #t
(display (bidirectional-counter '? n)) (newline) ;; #f
(display (bidirectional-counter '? m)) (newline) ;; #t
(display (n 'inc)) (newline) ;; 1
(display (m 'inc)) (newline) ;; 1
(display (m 'dec)) (newline) ;; 0