Current mood:

mellow

A Trivial Un-Object System for Scheme

You could say I'm a casual user of Scheme. At least, I've mostly used it for prototyping and system scripts. But I decided, to use it and to learn from it, that I'd make something a little different: an un-object system.

What I Wanted

There are a lot of object systems for Scheme, but they mostly help you create objects. I wanted an easy way to retrofit existing structures with encapsulation and late binding.

Some might say that late binding plus encapsulation is object oriented, but pretty much everyone expects more from anything claiming to be OO. Putting that aside, there's an assumption that when you define an object using an object system, your main job is to write the internals of the object. That's the opposite of what I wanted.

The typical way of creating a reusable data structure in Scheme is to represent it using nested lists and write a bunch of procedures that operate on that representation. Then those procedures can be used like so:

(define tasks (make-queue))
(queue-add! tasks 'clean-garage)
(queue-get! tasks)

Where tasks is really some kind of list structure storing your data. You might add several tasks to the queue and have tasks => '((clean-garage paint-roof) (sweep-steps)). Even libraries that come with an object system will often also come with such non-object data structures.

Encapsulation and late binding are, I think, the main advantages over the typical way for the consumer of the objects. Inheritance is mostly a convenience for the creator (except for its late binding aspect). So I wanted an easy way to add encapsulation and late binding to a typical data structure.

How to Use It

To set up the encapsulation, you use the hide macro. Like so:

(define make-hidden-queue
 (hide
  (queue make-queue)
  (unwrapped
   (add! queue-add!)
   (get! queue-get!))))

The result is a procedure that works like make-queue, except it makes an encapsulated queue. Then you can do:

(define tasks (make-hidden-queue))

 (let-access (add! get!)
  (add! tasks 'clean-garage)
  (get! tasks))

The let-access macro sets up some access procedures. The procedures have late binding, so you could also do:

(define make-bag
 (hide
  (bag make-tree-multiset)
  (unwrapped
   (add! tree-multiset-add!)
   (get! tree-multiset-extract-any!))))

(define other-tasks (make-bag))

(let-access (add! get!)
 (add! tasks 'clean-garage)
 (add! other-tasks (get! tasks))
 (get! other-tasks))

There are a couple things that might not be obvious about the queue and bag examples. The part right near the beginning that says simply bag or queue is just a label. It's included in the error message if you try to late-bind something that isn't listed in hide. The unwrapped means that the procedures do not return another data structure of the same type.

Here's a toy example that has both wrapped and unwrapped procedures:

(hide
 (immutable-stack list)
 (unwrapped
  (peek car)
  (size length))
 (wrapped
  (push (lambda (stack item) (cons item stack)))
  (pop cdr)))

This is an immutable stack. Unlike a regular stack, it's pushed and popped by creating a new stack with one more or one fewer items, leaving the original stack intact. There's no practical way to make the items themselves immutable¹, but the structure of the stack itself is never changed.

On the inside, this toy is implemented as a list. The wrapped procedures each take a naked stack-as-list as their first argument and return another. The hide macro takes care of exposing the input list and wrapping up the output list, just as it wraps the output of make-queue, make-tree-multiset, or in this case list.

The unwrapped procedures still take a naked structure as their first argument, but their result is not wrapped by hide.

How it Works

After all that explaining, the implementation is stupidly simple. In fact, it's the same closure-based idea that everyone mentions when they talk about building an object system. If I've contributed anything new (and I likely have not) it's the purpose of wrapping existing structures.

The procedures created by let-access just pass the appropriate symbol to their first argument, then apply that result to the remaining arguments:

(define-syntax let-access
 ;Create a lexical scope in which certain names are bound to
 ;interface procedures, e.g.
 ;(let-access (add empty?) (if (empty? x) (add x val)))
 (syntax-rules ()
  ((let-access (symbol ...) body ...)
   (let ((symbol (lambda (x . args) (apply (x (quote symbol)) args))) ...)
    body ...))))

You can also make the access procedures one at a time:

(define (make-accessor symbol)
 ;Create an accessor procedure.
 ;Useful when the symbol won't be known until runtime or the name
 ;is taken by an existing procedure
 (lambda (x . args) (apply (x symbol) args)))

Of course, you can also do it "by hand" with something like ((tasks 'add!) 'clean-garage).

The hide macro is a little less trivial because the wrapped and unwrapped sections both needed to be optional, and I wanted to allow multiple sections of each type in any order.²

(define-syntax hide
 ;Encapsulate a set of procedures over a "naked" data structure.
 ;The first subform is (interface-name constructor), and after that
 ;you can have any number of (type (name naked-accessor) ...) where the
 ;type is wrapped or unwrapped, e.g.
 ;(define make-heap (hide
 ; (heap make-reverse-garfinkle-heap)
 ; (unwrapped
 ;  (empty? rgh-empty?)
 ;  (insert! rgh-insert!)
 ;  (next! rgh-extract-next!))
 ; (wrapped (copy rgh-make-copy))))
 (syntax-rules (unwrapped wrapped)
  ((hide (interface-name constructor) subform ...)
   ;create wrapper that turns naked structure into encapsulated
   ;structure
   (letrec ((wrapper
    (lambda (naked)
     (lambda (symbol)
       (hide "subforms"
        (interface-name wrapper naked symbol) ;a.k.a. metadata
        subform ...)))))
    ;use the wrapper to return a modified constructor
    (lambda args (wrapper (apply constructor args)))))

  ((hide "subforms" metadata subform rest ...)
   ;recurse on subforms, passing each to the type-group processing
   (hide "type-group" metadata subform
    (hide "subforms" metadata rest ...)))

  ((hide "type-group" (interface-name wrapper naked symbol)
                      (type (name proc) ...)
                      subforms)
   ;each type-group becomes a case switch with the remaining subforms
   ;in the else clause
   (case symbol ('name (hide "procedure"
                        (interface-name wrapper naked symbol)
                        type proc)) ...
    (else subforms)))

  ((hide "subforms" (interface-name wrapper naked symbol))
    ;base case of recursion on subforms, fill in the right side of the
    ;final else clause
    (error "unknown interface symbol, no such accessor" symbol 'interface-name))

  ;The right sides of the case tests should be procedures that take a
  ;naked structure as the first argument.  The type (wrapped vs unwrapped)
  ;controlls whether the output of the provided procedure is wrapped in
  ;the same encapsulation before being returned.
  ((hide "procedure" (interface-name wrapper naked symbol)
                               wrapped proc)
   (lambda args (wrapper (apply proc (cons naked args)))))
  ((hide "procedure" (interface-name wrapper naked symbol)
                               unwrapped proc)
   (lambda args (apply proc (cons naked args))))))