├── .gitignore ├── .travis.yml ├── multimethod-doc ├── info.rkt └── scribblings │ ├── info.rkt │ └── multimethod.scrbl ├── multimethod-lib ├── info.rkt └── multimethod │ ├── main.rkt │ ├── multimethod.rkt │ └── privilege.rkt ├── multimethod-test ├── info.rkt └── tests │ └── multimethod │ ├── ignored-params.rkt │ └── multimethod.rkt └── multimethod └── info.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | compiled/ 2 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | sudo: false 4 | 5 | env: 6 | global: 7 | - RACKET_DIR: '~/racket' 8 | matrix: 9 | - RACKET_VERSION: 6.3 10 | - RACKET_VERSION: 6.4 11 | - RACKET_VERSION: HEAD 12 | 13 | before_install: 14 | - git clone https://github.com/greghendershott/travis-racket.git 15 | - cat travis-racket/install-racket.sh | bash 16 | - export PATH="${RACKET_DIR}/bin:${PATH}" 17 | 18 | install: 19 | - raco pkg install --auto --link $TRAVIS_BUILD_DIR/multimethod-lib 20 | - raco pkg install --auto --link $TRAVIS_BUILD_DIR/multimethod-doc 21 | - raco pkg install --auto --link $TRAVIS_BUILD_DIR/multimethod-test 22 | - raco pkg install --auto cover cover-coveralls 23 | 24 | script: 25 | - raco test -ep multimethod-lib multimethod-test 26 | - raco cover -bf coveralls -d $TRAVIS_BUILD_DIR/coverage -p multimethod-lib multimethod-test 27 | -------------------------------------------------------------------------------- /multimethod-doc/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps 6 | '("base" 7 | "multimethod-lib")) 8 | (define build-deps 9 | '("racket-doc" 10 | "scribble-lib")) 11 | -------------------------------------------------------------------------------- /multimethod-doc/scribblings/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define scribblings 4 | '(["multimethod.scrbl"])) 5 | -------------------------------------------------------------------------------- /multimethod-doc/scribblings/multimethod.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require racket/require 4 | (for-label multimethod 5 | (subtract-in 6 | (multi-in racket [base function]) 7 | multimethod)) 8 | scribble/eval) 9 | 10 | @(module base-forms racket/base 11 | (require (for-label racket/base) 12 | scribble/manual) 13 | (provide base:struct) 14 | (define base:struct @racket[struct])) 15 | 16 | @(require 'base-forms) 17 | 18 | @title{Dynamic multiple dispatch} 19 | 20 | @defmodule[multimethod] 21 | 22 | This library provides syntactic forms for defining and implementing @deftech{multimethods}, 23 | dynamically polymorphic functions that support 24 | @hyperlink["https://en.wikipedia.org/wiki/Multiple_dispatch"]{multiple dispatch}. Multimethods are 25 | functions that can have many different implementations depending on the types of arguments they are 26 | invoked on. For example, a generic @tt{add} function might have different implementations for adding 27 | scalars and vectors. 28 | 29 | Multimethods provide similar but distinct functionality from @racketmodname[racket/generic], which 30 | permits enhancing implementing structures in more powerful ways, but only supports 31 | @emph{single dispatch}. 32 | 33 | @section{Example} 34 | 35 | @(interaction 36 | #:eval ((make-eval-factory '(multimethod racket/function))) 37 | #:escape unsyntax 38 | 39 | (code:comment #,"a scalar value") 40 | (struct num (val)) 41 | (code:comment #,"an n-dimensional vector value") 42 | (struct vec (vals)) 43 | 44 | (code:comment #,"generic multiplication operator") 45 | (define-generic (mul a b)) 46 | 47 | (define-instance ((mul num num) x y) 48 | (num (* (num-val x) (num-val y)))) 49 | 50 | (define-instance ((mul num vec) n v) 51 | (vec (map (curry * (num-val n)) (vec-vals v)))) 52 | 53 | (define-instance ((mul vec num) v n) 54 | (mul n v)) 55 | 56 | (mul (num 6) (num 8)) 57 | (mul (num 2) (vec '(3 12))) 58 | (mul (vec '(3 12)) (num 2))) 59 | 60 | @section{API Reference} 61 | 62 | @defform[#:literals [_] 63 | (define-generic (name-id param-or-hole ...+)) 64 | #:grammar 65 | ([param-or-hole param-id _])]{ 66 | Defines a new multimethod with the name @racket[name-id]. Each @racket[param-or-hole] corresponds to 67 | a formal parameter to the function. Each argument given a name will be considered for dispatch, but 68 | arguments may be simply passed through by replacing them with @racket[_].} 69 | 70 | @defform*[[(define-instance (name-id type-id ...+) proc-expr) 71 | (define-instance ((name-id type-id ...+) formal-id ...+) body ...+)]]{ 72 | Defines a new instance of the multimethod bound by @racket[name-id] for the combination of types 73 | provided, where each @racket[type-id] refers to a 74 | @seclink["structinfo" #:doc '(lib "scribblings/reference/reference.scrbl")]{structure type transformer 75 | binding}. 76 | 77 | When using the first form of @racket[define-instance], @racket[proc-expr] should produce a procedure 78 | that will be invoked when an invokation of the multimethod matches the provided types. The second form 79 | is analogous to the usual function definition shorthand, such as the second form of @racket[define]. 80 | 81 | New multimethod instances cannot be defined on any combination of datatypes—there are rules that 82 | govern which instances are valid. Specifically, a multimethod instance is only valid if @emph{either} 83 | of the following conditions are met: 84 | 85 | @itemlist[ 86 | @item{The multimethod bound by @racket[name-id] was defined in the same module as the instance 87 | definition.} 88 | @item{@emph{Any} of the types bound by the @racket[type-id]s were defined in the same module as 89 | the instance definition.}] 90 | 91 | These requirements guarantee that there cannot be two conflicting instances defined in separate 92 | modules, which would cause problems when both loaded at the same time.} 93 | 94 | @defform[(struct id fields options)]{ 95 | Like @base:struct from @racketmodname[racket/base], but wrapped to cooperate with the instance 96 | validity checking of @racket[define-instance]. Additionally, all structs defined with this form are 97 | @racket[#:transparent]. Otherwise identical to @|base:struct|.} 98 | -------------------------------------------------------------------------------- /multimethod-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps 6 | '(["base" #:version "6.3"])) 7 | (define build-deps 8 | '("rackunit-lib" 9 | "rackunit-spec")) 10 | -------------------------------------------------------------------------------- /multimethod-lib/multimethod/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "multimethod.rkt") 4 | (provide (all-from-out "multimethod.rkt")) 5 | -------------------------------------------------------------------------------- /multimethod-lib/multimethod/multimethod.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/function 4 | racket/struct-info 5 | (for-syntax racket/base 6 | racket/function 7 | racket/list 8 | racket/provide-transform 9 | racket/struct-info 10 | racket/syntax 11 | syntax/parse 12 | "privilege.rkt")) 13 | 14 | (provide (rename-out [privileged-struct struct]) 15 | define-generic define-instance) 16 | 17 | (begin-for-syntax 18 | ; compile-time representation of a multimethod binding 19 | (struct multimethod (arity dispatch-table) 20 | #:transparent 21 | #:property prop:procedure 22 | (λ (method stx) 23 | (syntax-parse stx 24 | [(method arg ...) 25 | #'(apply-multimethod method (list arg ...))] 26 | [method 27 | #'(λ args (apply-multimethod method args))]))) 28 | 29 | ; each multimethod has a total arity and a set of indicies for which dispatch is actually performed 30 | ; for example, consider the definition of “map” — it has a total arity of 2, but dispatch is only 31 | ; performed on the second argument 32 | (struct dispatch-arity (total relevant-indicies) #:transparent) 33 | 34 | ; handles parsing multimethod arg lists into expressions that produce dispatch-arity structs 35 | (define-splicing-syntax-class multimethod-arity-spec 36 | #:attributes [dispatch-arity-expr] 37 | [pattern (~seq arg:id ...) 38 | #:attr dispatch-arity-expr 39 | #`(dispatch-arity #,(length (attribute arg)) 40 | '#,(for/list ([(id n) (in-indexed (attribute arg))] 41 | #:unless (free-identifier=? id #'_)) 42 | n))]) 43 | 44 | (define (assert-privileged-struct! id) 45 | (unless (id-privileged? id) 46 | (raise-syntax-error 'define-instance 47 | "expected name of struct defined in current module" 48 | id)))) 49 | 50 | ; replacement for the struct form that associates privilege information 51 | (define-syntax privileged-struct 52 | (syntax-parser 53 | [(_ name:id fields option ...) 54 | (mark-id-as-privileged! #'name) 55 | #'(struct name fields #:transparent option ...)])) 56 | 57 | (define-syntax define-generic 58 | (syntax-parser 59 | [(_ (method:id arity-spec:multimethod-arity-spec)) 60 | (with-syntax ([dispatch-table (generate-temporary #'method)]) 61 | (mark-id-as-privileged! #'method) 62 | #'(begin 63 | (define dispatch-table (make-hash)) 64 | (define-syntax method (multimethod arity-spec.dispatch-arity-expr #'dispatch-table))))])) 65 | 66 | (define-syntax define-instance 67 | (syntax-parser 68 | ; standard (define (proc ...) ...) shorthand 69 | [(_ ((method type:id ...+) . args) body:expr ...+) 70 | #'(define-instance (method type ...) (λ args body ...))] 71 | ; full (define proc lambda-expr) notation 72 | [(_ (method type:id ...+) proc:expr) 73 | (let* ([multimethod (syntax-local-value #'method)] 74 | [privileged? (id-privileged? #'method)]) 75 | ; don’t check struct privilege if the multimethod is itself privileged 76 | (unless (or privileged? (ormap id-privileged? (attribute type))) 77 | (assert-privileged-struct! (first (attribute type)))) 78 | (with-syntax ([dispatch-table (multimethod-dispatch-table multimethod)] 79 | [(struct-type-id ...) (map (compose1 first extract-struct-info syntax-local-value) 80 | (attribute type))]) 81 | #'(let ([struct-types (list struct-type-id ...)]) 82 | (hash-set! dispatch-table struct-types proc))))])) 83 | 84 | ; wrapper around struct-info that throws away the second value 85 | (define (struct-type-info s) 86 | (let-values ([(type complete?) (struct-info s)]) 87 | type)) 88 | 89 | ; application hook for multimethods; expands into do-apply-multimethod 90 | (define-syntax apply-multimethod 91 | (syntax-parser 92 | [(_ method args:expr) 93 | (let ([multimethod (syntax-local-value #'method)]) 94 | (with-syntax ([dispatch-table (multimethod-dispatch-table multimethod)] 95 | [relevant-indicies (dispatch-arity-relevant-indicies 96 | (multimethod-arity multimethod))]) 97 | #'(do-apply-multimethod dispatch-table (filter-indicies 'relevant-indicies) args)))])) 98 | 99 | ; Given a list of indicies and a list, returns a list with only the elements at the specified 100 | ; indicies. Used to get the args needed for dispatch from the arity’s relevant-indicies. 101 | ; (listof exact-nonnegative-integer?) -> list? -> list? 102 | (define ((filter-indicies indicies) lst) 103 | (for/list ([(x i) (in-indexed lst)] 104 | #:when (member i indicies)) 105 | x)) 106 | 107 | ; runtime implementation of multimethod dispatch and invocation 108 | (define (do-apply-multimethod dispatch-table map-args-to-dispatch args) 109 | (apply (hash-ref dispatch-table (map struct-type-info (map-args-to-dispatch args))) args)) 110 | 111 | (begin-for-syntax 112 | (module+ test 113 | (require rackunit 114 | rackunit/spec) 115 | 116 | (describe ":multimethod-arity-spec" 117 | (it "parses syntax to dispatch-arity structs" 118 | (check-equal? (syntax->datum 119 | (syntax-parse #'(a b c d) 120 | [(arity-spec:multimethod-arity-spec) 121 | (attribute arity-spec.dispatch-arity-expr)])) 122 | '(dispatch-arity 4 '(0 1 2 3))) 123 | 124 | (check-equal? (syntax->datum 125 | (syntax-parse #'(_ f _ _) 126 | [(arity-spec:multimethod-arity-spec) 127 | (attribute arity-spec.dispatch-arity-expr)])) 128 | '(dispatch-arity 4 '(1))) 129 | 130 | (check-equal? (syntax->datum 131 | (syntax-parse #'(_ a _ b _) 132 | [(arity-spec:multimethod-arity-spec) 133 | (attribute arity-spec.dispatch-arity-expr)])) 134 | '(dispatch-arity 5 '(1 3))))))) 135 | -------------------------------------------------------------------------------- /multimethod-lib/multimethod/privilege.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require syntax/id-set) 4 | 5 | (provide mark-id-as-privileged! 6 | id-privileged?) 7 | 8 | (define privileged-ids (mutable-free-id-set)) 9 | 10 | (define (mark-id-as-privileged! id) 11 | (free-id-set-add! privileged-ids id)) 12 | 13 | (define (id-privileged? id) 14 | (free-id-set-member? privileged-ids id)) 15 | -------------------------------------------------------------------------------- /multimethod-test/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps 6 | '("base" 7 | "multimethod-lib" 8 | "rackunit-lib")) 9 | (define build-deps 10 | '()) 11 | -------------------------------------------------------------------------------- /multimethod-test/tests/multimethod/ignored-params.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require multimethod 4 | rackunit) 5 | 6 | (define-generic (map _ f)) 7 | 8 | (struct nothing ()) 9 | (struct just (value)) 10 | 11 | (define-instance ((map just) f j) 12 | (just (f (just-value j)))) 13 | 14 | (define-instance ((map nothing) f _) 15 | (nothing)) 16 | 17 | (check-equal? (map add1 (just 2)) (just 3)) 18 | (check-equal? (map add1 (nothing)) (nothing)) 19 | -------------------------------------------------------------------------------- /multimethod-test/tests/multimethod/multimethod.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module struct-definitions racket/base 4 | (provide (struct-out num) 5 | (struct-out vec)) 6 | (struct num (val) #:transparent) 7 | (struct vec (val) #:transparent)) 8 | 9 | (module generic-definitions racket/base 10 | (require multimethod 11 | racket/function 12 | (submod ".." struct-definitions)) 13 | 14 | (provide add) 15 | 16 | (define-generic (add a b)) 17 | 18 | (define-instance ((add num num) a b) 19 | (num (+ (num-val a) (num-val b)))) 20 | (define-instance ((add num vec) n v) 21 | (vec (map (curry + (num-val n)) (vec-val v)))) 22 | (define-instance ((add vec num) v n) 23 | (add n v))) 24 | 25 | (module extra-definitions racket/base 26 | (require multimethod 27 | (submod ".." struct-definitions) 28 | (submod ".." generic-definitions)) 29 | (provide (struct-out bool)) 30 | 31 | (struct bool (val)) 32 | (define-instance ((add bool bool) a b) 33 | (bool (or (bool-val a) (bool-val b)))) 34 | (define-instance ((add bool num) b n) 35 | (bool (or (bool-val b) (not (= (num-val n) 0)))))) 36 | 37 | (require multimethod 38 | racket/function 39 | rackunit 40 | syntax/macro-testing) 41 | 42 | (require 'struct-definitions 43 | 'generic-definitions 44 | 'extra-definitions) 45 | 46 | (check-equal? (add (num 1) (num 2)) (num 3)) 47 | (check-equal? (add (num 1) (vec '(1 2 3))) (vec '(2 3 4))) 48 | (check-equal? (add (vec '(1 2 3)) (num 1)) (vec '(2 3 4))) 49 | 50 | (check-equal? (add (bool #f) (bool #f)) (bool #f)) 51 | (check-equal? (add (bool #t) (bool #f)) (bool #t)) 52 | (check-equal? (add (bool #f) (bool #t)) (bool #t)) 53 | (check-equal? (add (bool #t) (bool #t)) (bool #t)) 54 | 55 | (check-equal? (add (bool #f) (num 0)) (bool #f)) 56 | (check-equal? (add (bool #t) (num 0)) (bool #t)) 57 | (check-equal? (add (bool #f) (num 1)) (bool #t)) 58 | 59 | (check-exn #rx"^define-instance: expected name of struct defined in current module$" 60 | (thunk (convert-syntax-error (define-instance ((add num bool) n b) 61 | (bool (or (not (= (num-val n) 0)) (bool-val b))))))) 62 | -------------------------------------------------------------------------------- /multimethod/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps 6 | '("base" 7 | "multimethod-lib" 8 | "multimethod-doc")) 9 | (define build-deps 10 | '()) 11 | 12 | (define implies 13 | '("multimethod-lib" 14 | "multimethod-doc")) 15 | --------------------------------------------------------------------------------