From: Andre <andre@het.brown.edu>
Newsgroups: comp.lang.scheme
Subject: Typeclass envy
Date: Fri, 13 Feb 2004 12:18:16 -0500
Organization: Brown University Physics Department
Lines: 725
Message-ID: <402D06D8.A4007DE2@het.brown.edu>
NNTP-Posting-Host: now.het.brown.edu
Mime-Version: 1.0
Content-Type: text/plain; charset=us-ascii
Content-Transfer-Encoding: 7bit
X-Trace: saturn.services.brown.edu 1076692696 7857 128.148.26.45 (13 Feb 2004 17:18:16 GMT)
X-Complaints-To: news@nntp.brown.edu
NNTP-Posting-Date: Fri, 13 Feb 2004 17:18:16 +0000 (UTC)
X-Mailer: Mozilla 4.76 [en] (X11; U; SunOS 5.8 i86pc)
X-Accept-Language: en


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 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)))))