suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

racket/generic: eliminate ctc dependency in private interface

Browse Source 
Closes PR 13051
This commit is contained in:
Asumu Takikawa 2012-08-28 17:23:59 -04:00
parent 496bfd3b57
commit 466b4e2c60
6 changed files with 140 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/data/order.rkt
View File

@ -17,7 +17,8 @@
(define-generics (ordered-dict gen:ordered-dict prop:ordered-dict ordered-dict?
#:defined-table dict-def-table
;; private version needs all kw args, in order
#:prop-defined-already? #f)
#:prop-defined-already? #f
#:define-contract #f)
(dict-iterate-least ordered-dict)
(dict-iterate-greatest ordered-dict)
(dict-iterate-least/>? ordered-dict key)

125
collects/racket/generic.rkt
View File

@ -1,7 +1,9 @@
#lang racket/base
(require (rename-in "private/generic.rkt"
(require racket/contract/base
racket/contract/combinator
(rename-in "private/generic.rkt"
[define-generics define-generics/pre])
(for-syntax racket/base racket/local))
(for-syntax racket/base racket/local racket/syntax))
;; Convenience layer on top of racket/private/generic.
;; To avoid circular dependencies, racket/private/generic cannot use
@ -27,6 +29,121 @@
[gen:name (id "gen:" name-str)])
#'(define-generics/pre (name gen:name prop:name name?
#:defined-table defined-table
;; the following is not public
#:prop-defined-already? #f)
;; the following are not public
#:prop-defined-already? #f
#:define-contract define-generics-contract)
(generic . generics-args) ...)))]))
;; generate a contract combinator for instances of a generic interface
(define-syntax (define-generics-contract stx)
(syntax-case stx ()
[(_ name name? accessor (generic generic-idx) ...)
(with-syntax ([name/c (format-id #'name "~a/c" #'name)])
#`(define-syntax (name/c stx)
(syntax-case stx ()
[(_ [method-id ctc] (... ...))
(andmap (λ (id) (and (identifier? id)
;; make sure the ids are all
;; in the interface
(member (syntax-e id) (list 'generic ...))))
(syntax->list #'(method-id (... ...))))
#'(make-generic-instance/c
(quote #,(syntax-e #'name/c))
name?
accessor
(list 'method-id (... ...))
(list ctc (... ...))
(make-immutable-hash
(list (cons 'generic generic-idx) ...)))])))]))
;; make a generic instance contract
(define (make-generic-instance/c name name? accessor ids ctc-args method-map)
(define ctcs (coerce-contracts 'generic-instance/c ctc-args))
;; map method table indices to ids & projections
(define id+ctc-map
(for/hash ([id ids] [ctc ctcs])
(values (hash-ref method-map id)
(cons id (contract-projection ctc)))))
(cond [(andmap chaperone-contract? ctcs)
(chaperone-generic-instance/c
name name? ids ctcs accessor id+ctc-map method-map)]
[else
(impersonator-generic-instance/c
name name? ids ctcs accessor id+ctc-map method-map)]))
(define (generic-instance/c-name ctc)
(define method-names
(map (λ (id ctc) (build-compound-type-name id ctc))
(base-generic-instance/c-ids ctc)
(base-generic-instance/c-ctcs ctc)))
(apply build-compound-type-name
(cons (base-generic-instance/c-name ctc) method-names)))
;; redirect for use with chaperone-vector
(define ((method-table-redirect ctc blame) vec idx val)
(define id+ctc-map (base-generic-instance/c-id+ctc-map ctc))
(define maybe-id+ctc (hash-ref id+ctc-map idx #f))
(cond [maybe-id+ctc
(define id (car maybe-id+ctc))
(define proj (cdr maybe-id+ctc))
(define blame-string (format "the ~a method of" id))
((proj (blame-add-context blame blame-string)) val)]
[else val]))
;; projection for generic methods
(define ((generic-instance/c-proj proxy-struct proxy-vector) ctc)
(λ (blame)
;; for redirecting the method table accessor
(define (redirect struct v)
(proxy-vector
v
(method-table-redirect ctc blame)
(λ (vec i v) v)))
(λ (val)
(unless (contract-first-order-passes? ctc val)
(raise-blame-error
blame val
'(expected: "~s" given: "~e")
(contract-name ctc)
val))
(define accessor (base-generic-instance/c-accessor ctc))
(proxy-struct val accessor redirect))))
;; recognizes instances of this generic interface
(define ((generic-instance/c-first-order ctc) v)
(cond [((base-generic-instance/c-name? ctc) v)
(define accessor (base-generic-instance/c-accessor ctc))
(define method-table (accessor v))
(define ids (base-generic-instance/c-ids ctc))
(define ctcs (base-generic-instance/c-ctcs ctc))
(define method-map (base-generic-instance/c-method-map ctc))
;; do sub-contract first-order checks
(for/and ([id ids] [ctc ctcs])
(contract-first-order-passes?
ctc
(vector-ref method-table (hash-ref method-map id))))]
[else #f]))
;; name - for building ctc name
;; name? - for first-order checks
;; ids - for method names (used to build the ctc name)
;; ctcs - for the contract name
;; accessor - for chaperoning the struct type property
;; id+ctc-map - for chaperoning the method table vector
;; method-map - for first-order checks
(struct base-generic-instance/c
(name name? ids ctcs accessor id+ctc-map method-map))
(struct chaperone-generic-instance/c base-generic-instance/c ()
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:projection (generic-instance/c-proj chaperone-struct chaperone-vector)
#:first-order generic-instance/c-first-order
#:name generic-instance/c-name))
(struct impersonator-generic-instance/c base-generic-instance/c ()
#:property prop:contract
(build-contract-property
#:projection (generic-instance/c-proj impersonate-struct impersonate-vector)
#:first-order generic-instance/c-first-order
#:name generic-instance/c-name))

3
collects/racket/private/dict.rkt
View File

@ -5,7 +5,8 @@
(define-generics (dict gen:dict prop:dict dict? #:defined-table dict-def-table
;; private version needs all kw args, in order
#:prop-defined-already? #f)
#:prop-defined-already? #f
#:define-contract #f)
(dict-ref dict key [default])
(dict-set! dict key val)
(dict-set dict key val)

129
collects/racket/private/generic.rkt
View File

@ -1,7 +1,5 @@
#lang racket/base
(require racket/local
racket/contract/base
racket/contract/combinator
(for-syntax racket/base
racket/local
racket/syntax)
@ -25,7 +23,12 @@
;; are we being passed an existing struct property? If so,
;; this kw arg is bound to the struct property accessor, and
;; we don't define the struct property
#:prop-defined-already? defined-already?)
#:prop-defined-already? defined-already?
;; Passed in by `define-generics` in racket/generic.
;; This enables us to cut the dependency on racket/contract
;; for users of this private module. Pass in #f
;; to avoid defining a contract.
#:define-contract define-generics-contract)
(generic . generic-args) ...)
(and (identifier? #'header)
(identifier? #'name)
@ -139,8 +142,11 @@
[gen (in-vector (get-generics this))])
(values name (not (not gen)))))
;; Define the contract that goes with this generic interface
(define-generics-contract header name? get-generics
(generic generic-idx) ...)
#,@(if (syntax-e #'define-generics-contract)
(list #'(define-generics-contract header name? get-generics
(generic generic-idx) ...))
;; don't define a contract when given #f
'())
;; Define generic functions
(define generic
(generic-arity-coerce
@ -164,116 +170,3 @@
(raise-argument-error 'generic name-str this))))))
...)))]))
;; generate a contract combinator for instances of a generic interface
(define-syntax (define-generics-contract stx)
(syntax-case stx ()
[(_ name name? accessor (generic generic-idx) ...)
(with-syntax ([name/c (format-id #'name "~a/c" #'name)])
#`(define-syntax (name/c stx)
(syntax-case stx ()
[(_ [method-id ctc] (... ...))
(andmap (λ (id) (and (identifier? id)
;; make sure the ids are all
;; in the interface
(member (syntax-e id) (list 'generic ...))))
(syntax->list #'(method-id (... ...))))
#'(make-generic-instance/c
(quote #,(syntax-e #'name/c))
name?
accessor
(list 'method-id (... ...))
(list ctc (... ...))
(make-immutable-hash
(list (cons 'generic generic-idx) ...)))])))]))
;; make a generic instance contract
(define (make-generic-instance/c name name? accessor ids ctc-args method-map)
(define ctcs (coerce-contracts 'generic-instance/c ctc-args))
;; map method table indices to ids & projections
(define id+ctc-map
(for/hash ([id ids] [ctc ctcs])
(values (hash-ref method-map id)
(cons id (contract-projection ctc)))))
(cond [(andmap chaperone-contract? ctcs)
(chaperone-generic-instance/c
name name? ids ctcs accessor id+ctc-map method-map)]
[else
(impersonator-generic-instance/c
name name? ids ctcs accessor id+ctc-map method-map)]))
(define (generic-instance/c-name ctc)
(define method-names
(map (λ (id ctc) (build-compound-type-name id ctc))
(base-generic-instance/c-ids ctc)
(base-generic-instance/c-ctcs ctc)))
(apply build-compound-type-name
(cons (base-generic-instance/c-name ctc) method-names)))
;; redirect for use with chaperone-vector
(define ((method-table-redirect ctc blame) vec idx val)
(define id+ctc-map (base-generic-instance/c-id+ctc-map ctc))
(define maybe-id+ctc (hash-ref id+ctc-map idx #f))
(cond [maybe-id+ctc
(define id (car maybe-id+ctc))
(define proj (cdr maybe-id+ctc))
(define blame-string (format "the ~a method of" id))
((proj (blame-add-context blame blame-string)) val)]
[else val]))
;; projection for generic methods
(define ((generic-instance/c-proj proxy-struct proxy-vector) ctc)
(λ (blame)
;; for redirecting the method table accessor
(define (redirect struct v)
(proxy-vector
v
(method-table-redirect ctc blame)
(λ (vec i v) v)))
(λ (val)
(unless (contract-first-order-passes? ctc val)
(raise-blame-error
blame val
'(expected: "~s" given: "~e")
(contract-name ctc)
val))
(define accessor (base-generic-instance/c-accessor ctc))
(proxy-struct val accessor redirect))))
;; recognizes instances of this generic interface
(define ((generic-instance/c-first-order ctc) v)
(cond [((base-generic-instance/c-name? ctc) v)
(define accessor (base-generic-instance/c-accessor ctc))
(define method-table (accessor v))
(define ids (base-generic-instance/c-ids ctc))
(define ctcs (base-generic-instance/c-ctcs ctc))
(define method-map (base-generic-instance/c-method-map ctc))
;; do sub-contract first-order checks
(for/and ([id ids] [ctc ctcs])
(contract-first-order-passes?
ctc
(vector-ref method-table (hash-ref method-map id))))]
[else #f]))
;; name - for building ctc name
;; name? - for first-order checks
;; ids - for method names (used to build the ctc name)
;; ctcs - for the contract name
;; accessor - for chaperoning the struct type property
;; id+ctc-map - for chaperoning the method table vector
;; method-map - for first-order checks
(struct base-generic-instance/c
(name name? ids ctcs accessor id+ctc-map method-map))
(struct chaperone-generic-instance/c base-generic-instance/c ()
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:projection (generic-instance/c-proj chaperone-struct chaperone-vector)
#:first-order generic-instance/c-first-order
#:name generic-instance/c-name))
(struct impersonator-generic-instance/c base-generic-instance/c ()
#:property prop:contract
(build-contract-property
#:projection (generic-instance/c-proj impersonate-struct impersonate-vector)
#:first-order generic-instance/c-first-order
#:name generic-instance/c-name))

3
collects/racket/stream.rkt
View File

@ -41,7 +41,8 @@
(define-generics (-stream gen:stream prop:stream stream?
#:defined-table defined-table
#:prop-defined-already? stream-get-generics)
#:prop-defined-already? stream-get-generics
#:define-contract #f)
;; These three are never used for the reasons explained above.
;; We still need the headers for clients who extend racket/stream.
(stream-empty? -stream)

3
collects/tests/generic/iterator.rkt
View File

@ -33,7 +33,8 @@
(define-generics (iterator gen:iterator prop:iterator iterator?
#:defined-table dummy
#:prop-defined-already? iterator-accessor)
#:prop-defined-already? iterator-accessor
#:define-contract #f)
(iterator-first iterator)
(iterator-rest iterator)
(iterator-continue? iterator))