Add Haskell-style typeclasses with dictionary passing (#24)
ober
8f7eccccdc53cba7d17740e299d583d9afcd2af1
new file mode 100644 --- /dev/null +++ b/lib/std/misc/typeclass.sls @@ -0,0 +1,206 @@ +#!chezscheme +;;; (std misc typeclass) — Haskell-style typeclasses via dictionary-passing +;;; +;;; (define-typeclass (Eq a) +;;; (eq? a a -> boolean)) +;;; +;;; (define-instance (Eq number) +;;; (eq? =)) +;;; +;;; (tc-apply 'Eq 'eq? 'number 1 2) => #f +;;; (tc-apply 'Show '->string 'number 42) => "42" + +(library (std misc typeclass) + (export define-typeclass define-instance + typeclass-dispatch tc-apply tc-ref + typeclass-instance? typeclass-instance-of? + lookup-instance lookup-typeclass + register-typeclass! register-instance! + build-instance-dict) + (import (chezscheme)) + + ;; --------------------------------------------------------------- + ;; Global dispatch table: (class-name . type-name) -> dictionary + ;; --------------------------------------------------------------- + (define *instance-table* (make-hashtable equal-hash equal?)) + + (define (register-instance! class-name type-name dict) + (hashtable-set! *instance-table* (cons class-name type-name) dict)) + + (define (lookup-instance class-name type-name) + (hashtable-ref *instance-table* (cons class-name type-name) #f)) + + ;; --------------------------------------------------------------- + ;; Typeclass metadata + ;; --------------------------------------------------------------- + (define-record-type typeclass-meta + (fields name method-names superclasses)) + + (define *typeclass-registry* (make-hashtable symbol-hash symbol=?)) + + (define (register-typeclass! name method-names supers) + (hashtable-set! *typeclass-registry* name + (make-typeclass-meta name method-names supers))) + + (define (lookup-typeclass name) + (hashtable-ref *typeclass-registry* name #f)) + + ;; --------------------------------------------------------------- + ;; Predicates + ;; --------------------------------------------------------------- + (define (typeclass-instance? class-name type-name) + (and (lookup-instance class-name type-name) #t)) + + (define (typeclass-instance-of? class-name type-name) + (typeclass-instance? class-name type-name)) + + ;; --------------------------------------------------------------- + ;; Dispatch + ;; --------------------------------------------------------------- + (define (typeclass-dispatch class-name type-name method-name) + (let ([dict (lookup-instance class-name type-name)]) + (unless dict + (error 'typeclass-dispatch + (format "no instance of ~a for type ~a" class-name type-name))) + (let ([proc (hashtable-ref dict method-name #f)]) + (unless proc + (error 'typeclass-dispatch + (format "no method ~a in ~a instance for ~a" + method-name class-name type-name))) + proc))) + + (define tc-ref typeclass-dispatch) + + (define (tc-apply class-name method-name type-name . args) + (let ([proc (typeclass-dispatch class-name type-name method-name)]) + (apply proc args))) + + ;; --------------------------------------------------------------- + ;; build-instance-dict — build a dictionary, inheriting superclass methods + ;; --------------------------------------------------------------- + (define (build-instance-dict class-name type-name method-pairs) + (let ([dict (make-hashtable symbol-hash symbol=?)]) + ;; Copy superclass methods first + (let ([meta (lookup-typeclass class-name)]) + (when (and meta (not (null? (typeclass-meta-superclasses meta)))) + (for-each + (lambda (super-name) + (let ([super-dict (lookup-instance super-name type-name)]) + (when super-dict + (let-values ([(keys vals) (hashtable-entries super-dict)]) + (vector-for-each + (lambda (k v) (hashtable-set! dict k v)) + keys vals))))) + (typeclass-meta-superclasses meta)))) + ;; Add own methods + (for-each + (lambda (pair) (hashtable-set! dict (car pair) (cdr pair))) + method-pairs) + dict)) + + ;; --------------------------------------------------------------- + ;; define-typeclass macro + ;; + ;; (define-typeclass (Eq a) + ;; (eq? a a -> boolean)) + ;; + ;; (define-typeclass (Ord a) extends (Eq a) + ;; (compare a a -> integer) ...) + ;; + ;; Expands to a definition to stay in R6RS definition context. + ;; --------------------------------------------------------------- + (define-syntax define-typeclass + (lambda (stx) + (syntax-case stx (extends) + [(_ (class-name a) extends (super-name a2) (method-name . sig) ...) + #'(define class-name + (begin + (register-typeclass! 'class-name '(method-name ...) '(super-name)) + 'class-name))] + [(_ (class-name a) (method-name . sig) ...) + #'(define class-name + (begin + (register-typeclass! 'class-name '(method-name ...) '()) + 'class-name))]))) + + ;; --------------------------------------------------------------- + ;; define-instance macro + ;; + ;; (define-instance (Eq number) + ;; (eq? =)) + ;; + ;; Expands to a definition using a generated name. + ;; --------------------------------------------------------------- + (define-syntax define-instance + (lambda (stx) + (syntax-case stx () + [(_ (class-name type-name) (method-name impl) ...) + (with-syntax ([inst-id (datum->syntax #'class-name (gensym "inst"))]) + #'(define inst-id + (let ([dict (build-instance-dict + 'class-name 'type-name + (list (cons 'method-name impl) ...))]) + (register-instance! 'class-name 'type-name dict) + dict)))]))) + + ;; --------------------------------------------------------------- + ;; Built-in typeclasses + ;; --------------------------------------------------------------- + + ;; Eq + (define-typeclass (Eq a) + (eq? a a -> boolean)) + + ;; Ord (extends Eq) + (define-typeclass (Ord a) extends (Eq a) + (compare a a -> integer) + (lt? a a -> boolean) + (gt? a a -> boolean) + (le? a a -> boolean) + (ge? a a -> boolean)) + + ;; Show + (define-typeclass (Show a) + (->string a -> string)) + + ;; --------------------------------------------------------------- + ;; Built-in instances + ;; --------------------------------------------------------------- + + ;; Helpers + (define (number-compare a b) + (cond [(< a b) -1] [(> a b) 1] [else 0])) + (define (string-compare a b) + (cond [(string<? a b) -1] [(string>? a b) 1] [else 0])) + + ;; Eq + (define-instance (Eq number) + (eq? =)) + (define-instance (Eq string) + (eq? string=?)) + (define-instance (Eq symbol) + (eq? symbol=?)) + + ;; Ord + (define-instance (Ord number) + (compare number-compare) + (lt? <) + (gt? >) + (le? <=) + (ge? >=)) + (define-instance (Ord string) + (compare string-compare) + (lt? string<?) + (gt? string>?) + (le? string<=?) + (ge? string>=?)) + + ;; Show + (define-instance (Show number) + (->string number->string)) + (define-instance (Show string) + (->string (lambda (s) s))) + (define-instance (Show symbol) + (->string symbol->string)) + +) ;; end library --- a/tests/test-typeclass.ss +++ b/tests/test-typeclass.ss @@ -1,209 +1,264 @@ +#!/usr/bin/env scheme-script #!chezscheme -;;; Tests for (std typed typeclass) — Type class system - -(import (chezscheme) (std typed typeclass)) - -(define pass 0) -(define fail 0) - -(define-syntax test - (syntax-rules () - [(_ name expr expected) - (guard (exn [#t (set! fail (+ fail 1)) - (printf "FAIL ~a: ~a~%" name - (if (message-condition? exn) (condition-message exn) exn))]) - (let ([got expr]) - (if (equal? got expected) - (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) - (begin (set! fail (+ fail 1)) - (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) - -(printf "--- Phase 2c: Type Classes ---~%~%") - -;; ========== Basic class definition ========== - -(define-class Eq - (== a b) - (/= a b)) - -(test "class is a descriptor" - (vector? Eq) - #t) - -;; ========== Instance registration ========== - -(define-instance Eq fixnum - (== equal?) - (/= (lambda (a b) (not (equal? a b))))) - -(define-instance Eq string - (== string=?) - (/= (lambda (a b) (not (string=? a b))))) - -(test "instance-of/fixnum returns hashtable" - (hashtable? (instance-of 'Eq 'fixnum)) - #t) - -(test "instance-of/string returns hashtable" - (hashtable? (instance-of 'Eq 'string)) - #t) - -(test "instance-of/unknown returns #f" - (instance-of 'Eq 'unknown-type) - #f) - -;; ========== class-method ========== - -(test "class-method/== for fixnum" - (let* ([inst (instance-of 'Eq 'fixnum)] - [proc (class-method inst '==)]) - (proc 5 5)) - #t) - -(test "class-method//= for fixnum" - (let* ([inst (instance-of 'Eq 'fixnum)] - [proc (class-method inst '/=)]) - (proc 1 2)) - #t) - -(test "class-method/== for string" - (let* ([inst (instance-of 'Eq 'string)] - [proc (class-method inst '==)]) - (proc "hello" "hello")) - #t) - -(test "class-method//= for string" - (let* ([inst (instance-of 'Eq 'string)] - [proc (class-method inst '/=)]) - (proc "a" "b")) - #t) - -(test "class-method/missing returns #f" - (let ([inst (instance-of 'Eq 'fixnum)]) - (class-method inst 'nonexistent)) - #f) - -;; ========== with-class ========== - -(test "with-class/== fixnum equal" - (with-class Eq - (Eq == 42 42)) - #t) - -(test "with-class/== fixnum not equal" - (with-class Eq - (Eq == 1 2)) - #f) - -(test "with-class//= fixnum" - (with-class Eq - (Eq /= 3 4)) - #t) - -(test "with-class/== string" - (with-class Eq - (Eq == "abc" "abc")) - #t) - -(test "with-class//= string" - (with-class Eq - (Eq /= "x" "y")) - #t) - -(test "with-class/body has multiple exprs" - (with-class Eq - (Eq == 1 1) - (Eq /= 1 2)) - #t) - -;; ========== Multiple classes ========== - -(define-class Show - (show v)) - -(define-instance Show fixnum - (show number->string)) - -(define-instance Show string - (show (lambda (s) (string-append "\"" s "\"")))) - -(test "Show/fixnum" - (with-class Show - (Show show 42)) - "42") - -(test "Show/string" - (with-class Show - (Show show "hi")) - "\"hi\"") - -;; ========== Type inference ========== - -;; infer-type-tag covers standard Scheme types -(test "type inference: fixnum" - (let* ([inst (instance-of 'Eq 'fixnum)] - [proc (class-method inst '==)]) - (procedure? proc)) - #t) - -(test "type inference: string" - (let* ([inst (instance-of 'Eq 'string)] - [proc (class-method inst '==)]) - (procedure? proc)) - #t) - -;; ========== Error cases ========== - -(test "define-instance/unknown class errors" - (guard (exn [#t (condition-message exn)]) - (define-instance NonExistentClass foo - (method (lambda (x) x)))) - "unknown class") - -(test "with-class/no instance errors" - (guard (exn [#t (condition-message exn)]) - (with-class Eq - (Eq == 'some-symbol 'other))) - "no instance for type") - -;; ========== Ord class with multiple methods ========== - -(define-class Ord - (< a b) - (> a b) - (<= a b) - (>= a b)) - -(define-instance Ord fixnum - (< (lambda (a b) (fx< a b))) - (> (lambda (a b) (fx> a b))) - (<= (lambda (a b) (fx<= a b))) - (>= (lambda (a b) (fx>= a b)))) - -(test "Ord/< true" - (with-class Ord - (Ord < 1 2)) - #t) - -(test "Ord/< false" - (with-class Ord - (Ord < 2 1)) - #f) - -(test "Ord/> true" - (with-class Ord - (Ord > 5 3)) - #t) - -(test "Ord/<= equal" - (with-class Ord - (Ord <= 4 4)) - #t) - -(test "Ord/>= greater" - (with-class Ord - (Ord >= 10 5)) - #t) - -(printf "~%Results: ~a passed, ~a failed~%" pass fail) -(when (> fail 0) (exit 1)) +(import (chezscheme) + (std misc typeclass)) + +(define (string-contains haystack needle) + (let ([hlen (string-length haystack)] + [nlen (string-length needle)]) + (let loop ([i 0]) + (cond + [(> (+ i nlen) hlen) #f] + [(string=? (substring haystack i (+ i nlen)) needle) i] + [else (loop (+ i 1))])))) + +(define test-count 0) +(define pass-count 0) + +(define (test name thunk) + (set! test-count (+ test-count 1)) + (guard (e [#t (display "FAIL: ") (display name) (newline) + (display " Error: ") (display (condition-message e)) (newline)]) + (thunk) + (set! pass-count (+ pass-count 1)) + (display "PASS: ") (display name) (newline))) + +(define (assert-equal actual expected msg) + (unless (equal? actual expected) + (error 'assert-equal + (string-append msg ": expected " (format "~s" expected) + " got " (format "~s" actual))))) + +(define (assert-true val msg) + (unless val + (error 'assert-true (string-append msg ": expected #t")))) + +(define (assert-false val msg) + (when val + (error 'assert-false (string-append msg ": expected #f")))) + +;; ============================================================= +;; Eq typeclass tests +;; ============================================================= + +(test "Eq number: equal values" + (lambda () + (assert-true (tc-apply 'Eq 'eq? 'number 1 1) "1 == 1"))) + +(test "Eq number: unequal values" + (lambda () + (assert-false (tc-apply 'Eq 'eq? 'number 1 2) "1 != 2"))) + +(test "Eq string: equal" + (lambda () + (assert-true (tc-apply 'Eq 'eq? 'string "hello" "hello") "hello == hello"))) + +(test "Eq string: unequal" + (lambda () + (assert-false (tc-apply 'Eq 'eq? 'string "hello" "world") "hello != world"))) + +(test "Eq symbol: equal" + (lambda () + (assert-true (tc-apply 'Eq 'eq? 'symbol 'foo 'foo) "foo == foo"))) + +(test "Eq symbol: unequal" + (lambda () + (assert-false (tc-apply 'Eq 'eq? 'symbol 'foo 'bar) "foo != bar"))) + +;; ============================================================= +;; Ord typeclass tests +;; ============================================================= + +(test "Ord number: compare less" + (lambda () + (assert-equal (tc-apply 'Ord 'compare 'number 1 2) -1 "1 < 2"))) + +(test "Ord number: compare equal" + (lambda () + (assert-equal (tc-apply 'Ord 'compare 'number 5 5) 0 "5 == 5"))) + +(test "Ord number: compare greater" + (lambda () + (assert-equal (tc-apply 'Ord 'compare 'number 3 1) 1 "3 > 1"))) + +(test "Ord number: lt?" + (lambda () + (assert-true (tc-apply 'Ord 'lt? 'number 1 2) "1 < 2") + (assert-false (tc-apply 'Ord 'lt? 'number 2 1) "not 2 < 1"))) + +(test "Ord number: gt?" + (lambda () + (assert-true (tc-apply 'Ord 'gt? 'number 5 3) "5 > 3") + (assert-false (tc-apply 'Ord 'gt? 'number 3 5) "not 3 > 5"))) + +(test "Ord number: le?" + (lambda () + (assert-true (tc-apply 'Ord 'le? 'number 1 2) "1 <= 2") + (assert-true (tc-apply 'Ord 'le? 'number 2 2) "2 <= 2") + (assert-false (tc-apply 'Ord 'le? 'number 3 2) "not 3 <= 2"))) + +(test "Ord number: ge?" + (lambda () + (assert-true (tc-apply 'Ord 'ge? 'number 5 3) "5 >= 3") + (assert-true (tc-apply 'Ord 'ge? 'number 3 3) "3 >= 3") + (assert-false (tc-apply 'Ord 'ge? 'number 2 3) "not 2 >= 3"))) + +(test "Ord string: compare" + (lambda () + (assert-equal (tc-apply 'Ord 'compare 'string "apple" "banana") -1 "apple < banana") + (assert-equal (tc-apply 'Ord 'compare 'string "banana" "apple") 1 "banana > apple") + (assert-equal (tc-apply 'Ord 'compare 'string "same" "same") 0 "same == same"))) + +(test "Ord string: lt? gt?" + (lambda () + (assert-true (tc-apply 'Ord 'lt? 'string "a" "b") "a < b") + (assert-true (tc-apply 'Ord 'gt? 'string "z" "a") "z > a"))) + +;; ============================================================= +;; Ord inherits Eq (superclass test) +;; ============================================================= + +(test "Ord number inherits Eq: eq? method available" + (lambda () + (assert-true (tc-apply 'Ord 'eq? 'number 42 42) "Ord has eq? from Eq") + (assert-false (tc-apply 'Ord 'eq? 'number 42 43) "Ord eq? false"))) + +(test "Ord string inherits Eq: eq? method available" + (lambda () + (assert-true (tc-apply 'Ord 'eq? 'string "x" "x") "Ord has eq? from Eq"))) + +;; ============================================================= +;; Show typeclass tests +;; ============================================================= + +(test "Show number" + (lambda () + (assert-equal (tc-apply 'Show '->string 'number 42) "42" "show 42"))) + +(test "Show string" + (lambda () + (assert-equal (tc-apply 'Show '->string 'string "hello") "hello" "show hello"))) + +(test "Show symbol" + (lambda () + (assert-equal (tc-apply 'Show '->string 'symbol 'foo) "foo" "show foo"))) + +;; ============================================================= +;; typeclass-dispatch / tc-ref +;; ============================================================= + +(test "typeclass-dispatch returns a procedure" + (lambda () + (let ([proc (typeclass-dispatch 'Eq 'number 'eq?)]) + (assert-true (procedure? proc) "is procedure") + (assert-true (proc 1 1) "1 == 1 via dispatch")))) + +(test "tc-ref is alias for typeclass-dispatch" + (lambda () + (let ([proc (tc-ref 'Show 'number '->string)]) + (assert-equal (proc 99) "99" "tc-ref works")))) + +;; ============================================================= +;; typeclass-instance? / typeclass-instance-of? +;; ============================================================= + +(test "typeclass-instance? positive" + (lambda () + (assert-true (typeclass-instance? 'Eq 'number) "Eq number exists") + (assert-true (typeclass-instance? 'Ord 'string) "Ord string exists") + (assert-true (typeclass-instance? 'Show 'symbol) "Show symbol exists"))) + +(test "typeclass-instance? negative" + (lambda () + (assert-false (typeclass-instance? 'Eq 'list) "Eq list doesn't exist") + (assert-false (typeclass-instance? 'Ord 'symbol) "Ord symbol doesn't exist"))) + +(test "typeclass-instance-of? is alias" + (lambda () + (assert-true (typeclass-instance-of? 'Show 'number) "alias works"))) + +;; ============================================================= +;; Error cases +;; ============================================================= + +(test "dispatch missing instance raises error" + (lambda () + (guard (e [#t (assert-true (string-contains (condition-message e) "no instance") + "error mentions 'no instance'")]) + (typeclass-dispatch 'Eq 'list 'eq?) + (error 'test "should have raised")))) + +(test "dispatch missing method raises error" + (lambda () + (guard (e [#t (assert-true (string-contains (condition-message e) "no method") + "error mentions 'no method'")]) + (typeclass-dispatch 'Eq 'number 'nonexistent) + (error 'test "should have raised")))) + +;; ============================================================= +;; User-defined typeclass and instance +;; ============================================================= + +(define-typeclass (Hashable a) + (hash-code a -> integer)) + +(define-instance (Hashable number) + (hash-code (lambda (n) (modulo (abs (exact (truncate n))) 1000000007)))) + +(define-instance (Hashable string) + (hash-code (lambda (s) (string-hash s)))) + +(test "user-defined typeclass: Hashable number" + (lambda () + (let ([h (tc-apply 'Hashable 'hash-code 'number 42)]) + (assert-true (integer? h) "hash is integer") + (assert-equal h 42 "hash of 42 is 42")))) + +(test "user-defined typeclass: Hashable string" + (lambda () + (let ([h (tc-apply 'Hashable 'hash-code 'string "test")]) + (assert-true (integer? h) "hash is integer") + (assert-equal h (tc-apply 'Hashable 'hash-code 'string "test") "deterministic")))) + +;; ============================================================= +;; User-defined typeclass with superclass +;; ============================================================= + +(define-typeclass (Printable a) extends (Show a) + (print! a -> void)) + +(define-instance (Printable number) + (print! (lambda (n) (display (number->string n))))) + +(test "user-defined typeclass with superclass: inherits Show" + (lambda () + (assert-equal (tc-apply 'Printable '->string 'number 7) "7" + "inherited ->string"))) + +(test "user-defined typeclass with superclass: own method" + (lambda () + (let ([proc (tc-ref 'Printable 'number 'print!)]) + (assert-true (procedure? proc) "print! is procedure")))) + +;; ============================================================= +;; lookup-instance returns the dictionary +;; ============================================================= + +(test "lookup-instance returns hashtable" + (lambda () + (let ([dict (lookup-instance 'Eq 'number)]) + (assert-true (hashtable? dict) "is hashtable") + (assert-true (procedure? (hashtable-ref dict 'eq? #f)) "eq? is procedure")))) + +(test "lookup-instance returns #f for missing" + (lambda () + (assert-false (lookup-instance 'Eq 'list) "no Eq for list"))) + +;; ============================================================= +;; Summary +;; ============================================================= + +(newline) +(display (format "~a/~a tests passed.~n" pass-count test-count)) +(unless (= pass-count test-count) + (exit 1))