Typeclass envy
Andre
of programming in "type class style" in Scheme.
Type classes provide a level of abstraction superior to
CLOS-style generic functions in certain respects. For example,
a collection abstraction:
class (Collection a c) where
empty : c
insert : a c -> c
...
cannot be neatly expressed with OO or generic functions.
The problem is the signature of *empty* -- generic functions
cannot dispatch on the expected result type. The same is
true for *return* in the signature
class Monad m a where
return : a -> m a
...
Unfortunately type classes rely on static type inference to
resolve these ambiguities, which makes their implementation
problematic in Scheme. However, they can be simulated by
"dictionary passing" as happens under the hood in Haskell.
Although in its raw form, this technique is very burdensome
to the programmer, it can be substantially alleviated by
a few macros, as defined below.
In compensation, since the instances (dictionaries) of "type classes"
are now first class, the Scheme programmer gets a much more powerful
abstraction tool. Indeed, Haskell type classes have some
serious shortcomings, making them unsuitable for expressing
many very natural abstractions. For example, the integers
form a monoid under addition, and also under multiplication. In
Haskell, the integers can only be an instance of a monoid class
in one way. This problem does not arise with first class
instances. Consider also
class (Field f) (Abelian g) => Vectorspace f g where
dimension : Integer
...
This cannot be expressed in Haskell, since the type of
*dimension* would be ambiguous. Also, it is impossible to express
common operations such as taking the direct sum or tensor product
of two vector spaces. Again, this is no problem with first class
instances as defined below.
The implementation is below, along with a worked out Collections
example, a simple OO-ish example (drawing shapes) and an
extensible interpreter. But first, here is a short tutorial:
We define an equality and a collection
class, and a set class which inherits from both:
; class (Eq a) where
; egal? : a a -> boolean
; not-egal? : a a -> boolean = \x y -> not egal? x y
(define-class <Eq> egal?
not-egal?)
(define (default-Eq egal?)
(make-<Eq> egal?
(lambda (x y) (not (egal? x y)))))
; class (Collection a c) where
; empty : c
; insert : a c -> c
; ...
(define-class <Collection> empty
insert
fold)
; class (Eq a) (Collection a) => (Set a s) where
(define-class <Set> (<Eq> eq)
(<Collection> coll))
; We can now define a qualified *set-member?* function.
; Notice that in the scope of define=> we can automatically
; use operations defined in all superclasses of <Set>:
; (in this case fold from <Collection> and egal? from <Eq>):
; set-member? : (Set a s) => a s -> Bool
(define=> (set-member? <Set>)
(lambda (a c)
(call/cc (lambda (break)
(fold (lambda (x seed)
(if (egal? a x)
(break #t)
#f))
#f
c)))))
; Just for fun, let's define a heterogenous union.
; Notice how we can specify a prefix to append to
; the imported operations so as to disambiguate:
; heterogenous-union : (Set a sa) (Set b sb) => sa sb -> sa
(define=> (heterogenous-union (<Set> a.) (<Set> b.))
(lambda (x y)
(b.fold (lambda (elem accum)
(a.insert elem accum))
x
y)))
; To illustrate, let's define some instances.
; As opposed to Haskell, our instances are first class
; entities, which can be named.
; num-Eq = instance Eq Num where ...
; eqv-Eq = instance Eq a where ...
(define num-Eq (default-Eq =))
(define eqv-Eq (default-Eq eqv?))
; list-Set = instance (Eq a) => Set a [a] where
; empty = '()
; ...
(define (list-Set eq)
(letrec ((empty '())
(insert (lambda (x s)
(if ((set-member? this) x s)
s
(cons x s))))
(fold foldl)
(this (make-<Set> eq
(make-<Collection> empty
insert
fold))))
this))
; num-Set = instance Set Num [Num]
; eqv-Set = instance Set a [a]
(define num-Set (list-Set num-Eq))
(define eqv-Set (list-Set eqv-Eq))
; Examples of use. With opens the instance dictionary in
; lexical scope:
(with ((<Set> num-set))
(insert 1
(insert 2
(insert 3
(insert 1 empty))))) ;==> (2 3 1)
; Import, on the other hand, imports the bindings in the dictionary
; into the toplevel. As with *with* and *define*, we can specify
; prefixes to disambiguate:
(import (<Set> num-Set num.)
(<Set> eqv-Set))
(define num-test (num.insert 1 (num.insert 2 num.empty)))
(define eqv-test (insert 'a (insert 'b empty)))
((heterogenous-union eqv-Set num-Set) eqv-test num-test)
;==> (2 1 a b)
See below for a more fully worked out example, where we
extend the <Set> class with e.g. monomorphic union operations.
And yes, I am aware that this looks a lot like a simple first
class module calculus.
Andre van Tonder
;==========================================================
; This should work on any Scheme that has define-macro and
; Andrew-Wright's *match* library.
; MzScheme library imports:
(require (lib "list.ss" "mzlib"))
(require (lib "defmacro.ss"))
(require-for-syntax (lib "match.ss"))
(require-for-syntax (lib "list.ss" "mzlib"))
;===========================================================
;
; We define the forms:
; (define-class <field-form> ...)
; (define=> (<procedure-name> <class-form> ...) . body)
; (lambda=> (<class-form> ...) . body)
; (with (<instance-form> ...) . body)
; (import <instance-form> ...)
; <field-form> = field-label
; | (<superclass-name> field-label)
; <class-form> = <class-name>
; | (<class-name> <prefix-symbol>)
; <instance-form> = (<class-name> <instance-expr>)
; | (<class-name> <instance-expr> <prefix-symbol>)
(define-macro (define-class name . fields)
(let ((k (gensym))
(args (gensym))
(formals (map (lambda (field) (gensym)) fields))
(supers (filter pair? fields))
(labels (map (lambda (field)
(match field
((super label) label)
(label label)))
fields)))
`(begin
(define ,(string->symbol
(string-append "make-" (symbol->string name)))
(lambda ,formals
(lambda (,k) (,k . ,formals))))
(define-macro (,name ,k . ,args)
`(,,k "descriptor" ,',supers ,',labels . ,,args)))))
(define-macro (with . body)
(match body
((() . exps)
`(let () . ,exps))
((((name instance) . rest) . exps)
`(,name with
,name "" ,instance ,rest . ,exps))
((((name instance prefix) . rest) . exps)
`(,name with
,name ,(symbol->string prefix)
,instance ,rest . ,exps))
(("descriptor" supers labels name pre instance rest . exps)
(let ((pre-labels
(map (lambda (label)
(string->symbol
(string-append pre (symbol->string label))))
labels))
(super-bindings
(map (lambda (class-label)
`(,(car class-label)
,(string->symbol
(string-append pre
(symbol->string
(cadr class-label))))
,(string->symbol pre)))
supers)))
`(,instance (lambda ,pre-labels
(with ,super-bindings
(with ,rest . ,exps))))))))
(define-macro (import . bindings)
(match bindings
(()
"Bindings imported")
(((name instance) . rest)
`(,name import
,name "" ,instance ,rest))
(((name instance prefix) . rest)
`(,name import
,name ,(symbol->string prefix)
,instance ,rest))
(("descriptor" supers labels name pre instance rest)
(let ((pre-labels.temps
(map (lambda (label)
(cons
(string->symbol
(string-append pre (symbol->string label)))
(gensym)))
labels))
(super-bindings
(map (lambda (class-label)
`(,(car class-label)
,(string->symbol
(string-append pre
(symbol->string
(cadr class-label))))
,(string->symbol pre)))
supers)))
`(begin ,@(map (lambda (pre-label.temp)
`(define ,(car pre-label.temp) #f))
pre-labels.temps)
(,instance (lambda ,(map cdr pre-labels.temps)
,@(map (lambda (pre-label.temp)
`(set! ,(car pre-label.temp)
,(cdr pre-label.temp)))
pre-labels.temps)))
(import . ,super-bindings)
(import . ,rest))))))
(define-macro (lambda=> quals . body)
(let ((quals-binds (map (lambda (qual)
(match qual
((cls prefix) (list cls (gensym) prefix))
(cls (list cls (gensym)))))
quals)))
`(lambda ,(map cadr quals-binds)
(with ,quals-binds
. ,body))))
(define-macro (define=> name.quals . body)
(let ((name (car name.quals))
(quals (cdr name.quals)))
`(define ,name (lambda=> ,quals . ,body))))
;=======================================================
; Equality example:
; class (Eq a) where
; egal? : a a -> boolean
; not-egal? : a a -> boolean
(define-class <Eq> egal?
not-egal?)
(define (default-Eq egal?)
(make-<Eq> egal?
(lambda (x y) (not (egal? x y)))))
(define num-Eq (default-Eq =))
(define eqv-Eq (default-Eq eqv?))
(define chr-Eq (default-Eq char=?))
;======================================================
; Collections example;
; class (Collection a c) where
; empty : c
; insert : a c -> c
; ...
(define-class <Collection> empty
insert
fold)
; contains? : (Eq a) (Collection a c) => a c -> Bool
(define=> (contains? <Eq> <Collection>)
(lambda (a c)
(call/cc (lambda (break)
(fold (lambda (x seed)
(if (egal? a x)
(break #t)
#f))
#f
c)))))
; class (Eq a) (Collection a) => (Set a s) where
(define-class <Set> (<Eq> eq)
(<Collection> coll))
; set-member? : (Set a s) => a s -> Bool
(define=> (set-member? <Set>)
(contains? eq coll))
; instance (Eq a) => Set a [a]
(define (list-Set eq)
(letrec ((empty '())
(insert (lambda (x s)
(if ((set-member? this) x s)
s
(cons x s))))
(fold foldl)
(this (make-<Set> eq
(make-<Collection> empty
insert
fold))))
this))
; instance Set Num [Num]
; instance Set a [a]
(define num-Set (list-Set num-Eq))
(define eqv-Set (list-Set eqv-Eq))
; instance Set char string where ...
(define chr-Set
(letrec ((empty "")
(insert (lambda (x s)
(if ((set-member? this) x s)
s
(string-append (string x) s))))
(fold (lambda (f seed s)
(let loop ((acc seed)
(i 0))
(if (= i (string-length s))
acc
(loop (f (string-ref s i) acc)
(+ i 1))))))
(this (make-<Set> chr-Eq
(make-<Collection> empty
insert
fold))))
this))
; list->Set : (Set a s) => [a] -> s
(define=> (list->set <Set>)
(lambda (lst)
(foldl (lambda (x s) (insert x s))
empty
lst)))
; heterogenous-union : (Set a sa) (Set b sb) => sa sb -> sa
(define=> (heterogenous-union (<Set> a.) (<Set> b.))
(lambda (x y)
(b.fold (lambda (elem accum)
(a.insert elem accum))
x
y)))
;===============================================
; Extending the Set class:
; class (Set a s) => Set+ a s where
; union : s s -> s
; ...
(define-class <Set+> (<Set> set) union
member?
list->set)
; default-Set+ : (Set a s) -> (Set+ a s)
(define (default-Set+ sa)
(make-<Set+> sa
(heterogenous-union sa sa)
(set-member? sa)
(list->set sa)))
(define num-Set+ (default-Set+ num-Set))
(define chr-Set+ (default-Set+ chr-Set))
;----------------------------------------------------------
; Tests
(with ((<Set> num-Set))
empty) ;==> ()
((heterogenous-union eqv-Set chr-Set)
'(1 2 3 4 5)
"abcde") ;==> (#\e #\d #\c #\b #\a 1 2 3 4 5)
(with ((<Set+> num-Set+ num.)
(<Set+> chr-Set+ chr.))
(values
num.empty
chr.empty)) ;==> () ""
(import (<Set+> num-Set+ num.)
(<Set+> chr-Set+ chr.))
(num.union '(1 2 3 4 5)
'(3 4 5 6 7)) ;==> (7 6 1 2 3 4 5)
(chr.list->set '(#\a #\b #\c #\d #\a))
;==> "dcba"
(import (<Set+> num-Set+))
empty ;==> ()
(union '(1 2 3 4 5)
'(2 3 4 5 7)) ;==> (7 1 2 3 4 5)
(list->set '(1 1 2 3 4 3 4)) ;==> (4 3 2 1)
;===============================================================
; Simple Shapes OO example
; class (Shape a) where ...
; get-x : a -> Number
; get-y : a -> Number
; set-x : a x -> void
; set-y : a y -> void
; draw : a -> void
(define-class <Shape> get-x get-y set-x! set-y! draw)
(define-struct point (x y))
; draw-position : (Shape a) => a -> void
(define=> (draw-position <Shape>)
(lambda (a)
(display "Shape (")
(display (get-x a))
(display ", ")
(display (get-y a))
(display ")\n")))
; instance Shape point where ...
(define point-shape
(make-<Shape> point-x
point-y
set-point-x!
set-point-y!
(lambda (a)
((draw-position point-shape) a))))
(define-struct circle (x y radius))
; instance Shape circle-data
; where ...
(define circle-shape
(make-<Shape> circle-x
circle-y
set-circle-x!
set-circle-y!
(lambda (c)
(display "Circle: ")
((draw-position circle-shape) c)
(display " radius = ")
(display (circle-radius c))
(display "\n"))))
;--------------------------------------------------
; Tests
(define test-point (make-point 1 2))
(with ((<Shape> point-shape))
(draw test-point))
(define test-circle (make-circle 7 7 7))
(with ((<Shape> circle-shape))
(draw test-circle))
; draw-shapes : [exist a. ((Shape a) and a)] -> void
(define (draw-shapes lst)
(for-each (lambda (sa.a)
(with ((<Shape> (car sa.a)))
(draw (cdr sa.a))))
lst))
(draw-shapes (list (cons point-shape test-point)
(cons circle-shape test-circle)
(cons point-shape test-point)
(cons circle-shape test-circle)))
;========================================================
; Extending the Shape class:
(define-class <Shape+> (<Shape> shape) translate)
; translate : (Shape a) => a dx dy -> void
(define=> (translate <Shape>)
(lambda (a dx dy)
(set-x! a (+ (get-x a) dx))
(set-y! a (+ (get-y a) dy))))
(define point+
(make-<Shape+> point-shape
(translate point-shape)))
(define circle+
(make-<Shape+> circle-shape
(translate circle-shape)))
;-------------------------------------------------------
; Tests:
(with ((<Shape+> circle+))
(translate test-circle 7 7)
(draw test-circle))
(import (<Shape+> circle+))
(translate test-circle 7 7)
(draw test-circle)
;==============================================================
; Extensible interpreter.
;------------------------------------
; Uses variant types as defined here.
(define-syntax define-type
(syntax-rules ()
[(_ type (name field ...) ...)
(begin
(define-constructors type ((name field ...) ...)))]))
(define-syntax define-constructors
(syntax-rules ()
[(define-constructors type ((name field ...) ...))
(define-constructors type ((name field ...) ...) (name ...))]
[(define-constructors type ((name field ...) ...) names)
(begin
(define-constructor type (name field ...) names)
...)]))
(define-syntax define-constructor
(syntax-rules ()
[(_ type (name field ...) names)
(define (name field ...)
(cons 'type
(lambda names
(name field ...))))]))
(define-syntax cases
(syntax-rules ()
[(_ type x [(name field ...) exp]
...)
((cdr x) (lambda (field ...) exp)
...)]))
(define (type-of x) (car x))
;---------------------------------------
; class Interpreter Exp a where
; interpret : Exp a -> Number
(define-class Interpreter interpret)
(define-type base-expression (base))
; instance Interpreter base-expression where
; interpret (base) = error "No semantics"
(define base-interpreter
(make-Interpreter
(lambda (exp)
(cases base-expression exp
((base) (error "No Semantics"))))))
; type abel-expression a = base base-expression
; | num Number
; | plus a a
(define-type abel-expression
(base base-exp)
(num val)
(plus lhs rhs))
; instance (Promise (Interpreter a)) => Interpreter abel-expression a where
; interpret (base base-exp) = interpret base-exp
; interpret (num val) = val
; interpret (plus lhs rhs) = + (interpret lhs) (interpret rhs)
(define (abel-interpreter inta)
(make-Interpreter
(lambda (exp)
(with ((Interpreter (force inta)))
(cases abel-expression exp
((base base-exp)
(with ((Interpreter base-interpreter))
(interpret base-exp)))
((num val) val)
((plus lhs rhs)
(+ (interpret lhs) (interpret rhs))))))))
(define-type ring-expression
(abel abel-exp)
(mult lhs rhs))
; Instance (Promise (Interpreter a)) => Interpreter ring-expression a where
; ...
(define (ring-interpreter inta)
(make-Interpreter
(lambda (exp)
(with ((Interpreter (force inta)))
(cases abel-expression exp
((abel abel-exp)
(with ((Interpreter (abel-interpreter inta)))
(interpret abel-exp)))
((mult lhs rhs)
(* (interpret lhs) (interpret rhs))))))))
; Tie the knot: ;
; type final = ring-expression final
; ::::: implies, by the above, that
; instance Interpreter final
(define final-interpreter
(ring-interpreter (delay final-interpreter)))
;-----------------------------------------
; Test:
(with ((Interpreter final-interpreter))
(interpret
(mult (abel (num 2)) (abel (num 2)))))
Anton van Straaten
> I have come up with a few macros to alleviate the burden
> of programming in "type class style" in Scheme.
>
> Type classes provide a level of abstraction superior to
> CLOS-style generic functions in certain respects.
For anyone who's interested, I liked these macros so much that I converted
them to syntax-case:
http://www.appsolutions.com/code/typeclass.html
I can't promise anything about the elegance of the converted macros, since
my syntax-case abilities are not wizard-class. Critiques welcome.
The converted macros seem to work with the original examples in Andre's
post, and they also work with some other code I've written.
Anton
Andre
> I can't promise anything about the elegance of the converted macros, since
> my syntax-case abilities are not wizard-class. Critiques welcome.
I'm impressed! I have to admit that I tried syntax-case first but after a
couple of hours converted to define-macro when scoping issues got the better
of me.
Regards
Andre
Anton van Straaten
I took it as a bit of a challenge, and an opportunity to hone my syntax-case
skills (which were in need of honing). I also figured it would help me
understand the typeclass macros better, which it did.
Scoping was an issue, given the use of nested macros. To deal with that, I
used something which I hereby dub "scope-passing style", in which a
top-level macro passes a bit of syntax from its invocation location down to
the macros it invokes, so that identifier-generating calls to
datum->syntax-object at a lower level can use the scope from the outermost
macro. I don't know if there's a better way to do that sort of thing. I
was amazed when it worked! :)
Anton