diff --git a/pkgs/racket-test/tests/generic/defined-table.rkt b/pkgs/racket-test/tests/generic/defined-table.rkt new file mode 100644 index 0000000000..e9cae63f4d --- /dev/null +++ b/pkgs/racket-test/tests/generic/defined-table.rkt @@ -0,0 +1,63 @@ +#lang racket/base + +(require racket/generic) + +(define-generics cost + (money-cost cost) + (time-cost cost) + (happiness-cost cost) + #:defined-table cost-types) + +(struct food (name price calories) + #:methods gen:cost + [(define (money-cost x) + (food-price x)) + (define (happiness-cost x) + ;; Guilt from eating too many calories + (/ (- (max (food-calories x) 1000) 1000) 200))]) + +(struct laundry (num-loads) + #:methods gen:cost + [(define (money-cost x) + (* (laundry-num-loads x) 3)) + (define (time-cost x) + ;; It's really annoying to start laundry, but subsequent loads are okay + (+ 5 (laundry-num-loads x)))]) + +(define methods + (hash 'money-cost money-cost + 'time-cost time-cost + 'happiness-cost happiness-cost)) + +(define (total-cost stuff) + (for/sum ([thing stuff]) + (define supported-costs (cost-types thing)) + (for/sum ([cost-type (hash-keys methods)]) + (if (hash-ref supported-costs cost-type) + ((hash-ref methods cost-type) thing) + 0)))) + +(module+ test + (require rackunit rackunit/text-ui racket/port) + + (define (check-basics table) + (check-true (hash? table)) + (for ([method (hash-keys table)]) + (check-true (symbol? method)) + (check-true (boolean? (hash-ref table method))))) + + (define pizza (food 'pizza 8 1200)) + (define stuff (list pizza (laundry 1))) + (parameterize {[current-output-port (open-output-nowhere)]} + (run-tests + (test-suite + "defined-table" + (check-basics (cost-types pizza)) + (check-true (hash-ref (cost-types pizza) 'money-cost)) + (check-false (hash-ref (cost-types pizza) 'time-cost)) + (check-true (hash-ref (cost-types pizza) 'happiness-cost)) + + (check-basics (cost-types (car stuff))) + (check-basics (cost-types (cadr stuff))) + (check-equal? (total-cost stuff) 18))) + (void))) diff --git a/pkgs/racket-test/tests/generic/tests.rkt b/pkgs/racket-test/tests/generic/tests.rkt index acf016e234..8362ffe33b 100644 --- a/pkgs/racket-test/tests/generic/tests.rkt +++ b/pkgs/racket-test/tests/generic/tests.rkt @@ -3,6 +3,7 @@ (require (submod "custom-hash.rkt" test) (submod "alist.rkt" test) (submod "from-docs.rkt" test) + (submod "defined-table.rkt" test) (submod "stream.rkt" test) (submod "iterator.rkt" test) (submod "struct-form.rkt" test) diff --git a/racket/collects/racket/generic.rkt b/racket/collects/racket/generic.rkt index fbc9e01944..8fc95b11ca 100644 --- a/racket/collects/racket/generic.rkt +++ b/racket/collects/racket/generic.rkt @@ -152,7 +152,7 @@ (if table (with-syntax ([table-name table]) #'(define (table-name name) - (for/hasheq ([sym (in-list '(method ...))]) + (for/hasheq ([sym (in-list '(method-name ...))]) (values sym (support-name name sym))))) #'(begin))) #'(begin