Moved the-case-dispatch to ids.rkt
This commit is contained in:
Georges Dupéron
parent
92f18c3978
commit
9e3e2478bf
119
main.rkt
119
main.rkt
|
|
@ -14,8 +14,6 @@
|
||||||
;; Defines a literal which can be renamed, without conflicting with other
|
;; Defines a literal which can be renamed, without conflicting with other
|
||||||
;; poly literals, or identifiers with other meanings.
|
;; poly literals, or identifiers with other meanings.
|
||||||
define-poly-literal
|
define-poly-literal
|
||||||
;; TODO: move this to ids.rkt
|
|
||||||
the-case-dispatch
|
|
||||||
;; Defines a static overload for a polysemic method
|
;; Defines a static overload for a polysemic method
|
||||||
define-poly-case)
|
define-poly-case)
|
||||||
|
|
||||||
|
|
@ -34,21 +32,6 @@
|
||||||
racket/syntax)
|
racket/syntax)
|
||||||
(for-meta 2 racket/base))
|
(for-meta 2 racket/base))
|
||||||
|
|
||||||
(begin-for-syntax
|
|
||||||
(define/contract all-meanings (set/c symbol? #:kind 'mutable) (mutable-set))
|
|
||||||
(define/contract (register-meanings-end syms)
|
|
||||||
(-> (listof symbol?) void?)
|
|
||||||
(for ([meaning (in-list syms)])
|
|
||||||
(set-add! all-meanings meaning)))
|
|
||||||
|
|
||||||
(define/contract (register-meanings syms)
|
|
||||||
(-> (listof symbol?) void?)
|
|
||||||
(for ([meaning (in-list syms)])
|
|
||||||
(set-add! all-meanings meaning))
|
|
||||||
(syntax-local-lift-module-end-declaration
|
|
||||||
#`(begin-for-syntax
|
|
||||||
(register-meanings-end '#,syms)))))
|
|
||||||
|
|
||||||
;; Require transformers
|
;; Require transformers
|
||||||
;; _____________________________________________________________________________
|
;; _____________________________________________________________________________
|
||||||
|
|
||||||
|
|
@ -196,9 +179,6 @@
|
||||||
; 'initial-id)
|
; 'initial-id)
|
||||||
(pattern {~poly _ meaning})))))
|
(pattern {~poly _ meaning})))))
|
||||||
|
|
||||||
(begin-for-syntax
|
|
||||||
(struct a-case (f-id pred-id) #:transparent))
|
|
||||||
|
|
||||||
;; TODO: multimethods
|
;; TODO: multimethods
|
||||||
(define-syntax (define-poly-case stx)
|
(define-syntax (define-poly-case stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
|
|
@ -219,106 +199,15 @@
|
||||||
#,@(if (identifier-binding #'generated-normal-macro)
|
#,@(if (identifier-binding #'generated-normal-macro)
|
||||||
#'{}
|
#'{}
|
||||||
#'{(local-require
|
#'{(local-require
|
||||||
(only-in polysemy
|
(only-in polysemy/private/ids
|
||||||
[the-case-dispatch generated-normal-macro]))})
|
[the-case-dispatch generated-normal-macro]))})
|
||||||
#,@(if (identifier-binding #'generated-identifier-macro)
|
#,@(if (identifier-binding #'generated-identifier-macro)
|
||||||
#'{}
|
#'{}
|
||||||
#'{(local-require
|
#'{(local-require
|
||||||
(only-in polysemy
|
(only-in polysemy/private/ids
|
||||||
[the-case-dispatch generated-identifier-macro]))})
|
[the-case-dispatch
|
||||||
|
generated-identifier-macro]))})
|
||||||
(define/contract (tmp-f arg₀ argᵢ ...)
|
(define/contract (tmp-f arg₀ argᵢ ...)
|
||||||
(-> pred? (or/c 'argᵢ any/c) ... any)
|
(-> pred? (or/c 'argᵢ any/c) ... any)
|
||||||
. body)
|
. body)
|
||||||
(define-syntax generated-name (a-case #'tmp-f #'pred?)))))]))
|
(define-syntax generated-name (a-case #'tmp-f #'pred?)))))]))
|
||||||
|
|
||||||
(define-for-syntax contracts-supertypes #f)
|
|
||||||
(define-for-syntax contracts-expand #f)
|
|
||||||
(define-for-syntax (detect-overlap stx pred-ids)
|
|
||||||
;; Lazily fill in the supertypes hash table, to avoid compile-time costs
|
|
||||||
;; when the module is later required.
|
|
||||||
(unless contracts-supertypes
|
|
||||||
(set! contracts-supertypes
|
|
||||||
(make-free-id-table
|
|
||||||
`((,#'any/c . ())
|
|
||||||
(,#'string? . (,#'any/c))
|
|
||||||
(,#'exact-positive-integer? . (,#'exact-integer? ,#'positive?))
|
|
||||||
(,#'exact-integer . (,#'integer? ,#'exact?))
|
|
||||||
(,#'integer? . (,#'number?))
|
|
||||||
(,#'exact? . (,#'number?)) ;; not quite right
|
|
||||||
(,#'number? . (,#'any/c))
|
|
||||||
(,#'zero? . ,#'integer?)
|
|
||||||
#;…))))
|
|
||||||
;; Lazily fill in the "expansion" hash table, to avoid compile-time costs
|
|
||||||
;; when the module is later required.
|
|
||||||
(unless contracts-expand
|
|
||||||
(set! contracts-expand
|
|
||||||
(make-free-id-table
|
|
||||||
`((,#'exact-nonnegative-integer? . (,#'zero?
|
|
||||||
,#'exact-positive-integer?))
|
|
||||||
#;…))))
|
|
||||||
;; Build the set of covered contracts. When a contract is a union of two
|
|
||||||
;; disjoint contracts, it is replaced by these
|
|
||||||
;; (e.g. exact-nonnegative-integer? is replaced by zero? and
|
|
||||||
;; exact-positive-integer?)
|
|
||||||
(define covered-ids (mutable-free-id-set))
|
|
||||||
(for/list ([pred-id (in-list pred-ids)])
|
|
||||||
(define expanded*
|
|
||||||
(free-id-table-ref contracts-expand
|
|
||||||
pred-id
|
|
||||||
(λ () (list pred-id))))
|
|
||||||
(for ([expanded (in-list expanded*)])
|
|
||||||
(when (free-id-set-member? covered-ids expanded)
|
|
||||||
(raise-syntax-error 'polysemy
|
|
||||||
"some available function cases overlap"
|
|
||||||
stx
|
|
||||||
#f
|
|
||||||
pred-ids))
|
|
||||||
(free-id-set-add! covered-ids expanded)))
|
|
||||||
;; Move up the inheritance DAG, and see if any of the ancestors
|
|
||||||
;; is covered. Since we start with the parents of the user-supplied contract,
|
|
||||||
;; there will be no self-detection.
|
|
||||||
(define already-recur (mutable-free-id-set))
|
|
||||||
(define (recur pred-id)
|
|
||||||
(unless (free-id-set-member? already-recur pred-id)
|
|
||||||
(free-id-set-add! already-recur pred-id)
|
|
||||||
(when (free-id-set-member? covered-ids pred-id)
|
|
||||||
(raise-syntax-error 'polysemy
|
|
||||||
"some available function cases overlap"
|
|
||||||
stx
|
|
||||||
#f
|
|
||||||
pred-ids))
|
|
||||||
(for-each recur (free-id-table-ref contracts-supertypes pred-id))))
|
|
||||||
(for ([pred-id (in-list pred-ids)])
|
|
||||||
(apply recur (free-id-table-ref contracts-supertypes
|
|
||||||
pred-id))))
|
|
||||||
|
|
||||||
(define-for-syntax (the-case-dispatch-impl stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(id . args)
|
|
||||||
(identifier? #'id)
|
|
||||||
#`(#%app #,(the-case-dispatch-impl #'id) . args)]
|
|
||||||
[id
|
|
||||||
(identifier? #'id)
|
|
||||||
(let ()
|
|
||||||
(define/with-syntax ((f-id pred-id) ...)
|
|
||||||
(for*/list ([meaning (in-set all-meanings)]
|
|
||||||
[generated-name (in-value (gen-id #'id meaning))]
|
|
||||||
[slv (in-value
|
|
||||||
(syntax-local-value generated-name (λ () #f)))]
|
|
||||||
#:when (and slv (a-case? slv)))
|
|
||||||
(list (a-case-f-id slv)
|
|
||||||
(a-case-pred-id slv))))
|
|
||||||
;; Detect if there is overlap among the predicates, and raise an error
|
|
||||||
;; in that case.
|
|
||||||
(detect-overlap #'id (syntax->list #'(pred-id ...)))
|
|
||||||
;; TODO: for now, this only supports a single argument.
|
|
||||||
;; we should generalize it to support case-λ, and dispatch on
|
|
||||||
;; multiple arguments
|
|
||||||
;; TODO: use syntax-local-lift-module-end-declaration to cache
|
|
||||||
;; the generated dispatch functions.
|
|
||||||
#`(λ (arg)
|
|
||||||
(cond
|
|
||||||
[(pred-id arg) (f-id arg)]
|
|
||||||
...)))]))
|
|
||||||
|
|
||||||
(define-syntax the-case-dispatch the-case-dispatch-impl)
|
|
||||||
|
|
|
||||||
131
private/ids.rkt
131
private/ids.rkt
|
|
@ -2,13 +2,26 @@
|
||||||
|
|
||||||
(require racket/match
|
(require racket/match
|
||||||
(for-syntax racket/base
|
(for-syntax racket/base
|
||||||
|
racket/contract
|
||||||
|
racket/set
|
||||||
|
syntax/id-table
|
||||||
|
syntax/id-set
|
||||||
"utils.rkt"))
|
"utils.rkt"))
|
||||||
|
|
||||||
(provide
|
(provide
|
||||||
;; The only polysemic id (all others are renamings of this one)
|
;; The only polysemic id (all others are renamings of this one)
|
||||||
the-polysemic-id
|
the-polysemic-id
|
||||||
;; The only safeguard id (all others are renamings of this one)
|
;; The only safeguard id (all others are renamings of this one)
|
||||||
the-safeguard-id)
|
the-safeguard-id
|
||||||
|
;; The only case-dispatch macro (all others are renamings of this one)
|
||||||
|
the-case-dispatch
|
||||||
|
;; Records all known meanings
|
||||||
|
(for-syntax all-meanings
|
||||||
|
register-meanings))
|
||||||
|
(begin-for-syntax
|
||||||
|
(provide
|
||||||
|
;; Represents a single overload of a function
|
||||||
|
(struct-out a-case)))
|
||||||
|
|
||||||
;; We can have a safeguard identifier to detect uses of rename-in, rename-out
|
;; We can have a safeguard identifier to detect uses of rename-in, rename-out
|
||||||
;; and only-in, instead of their poly- counterparts. The safeguard
|
;; and only-in, instead of their poly- counterparts. The safeguard
|
||||||
|
|
@ -89,3 +102,119 @@
|
||||||
|
|
||||||
;; The only polysemic id (all others are renamings of this one)
|
;; The only polysemic id (all others are renamings of this one)
|
||||||
(define-syntax the-polysemic-id (polysemic))
|
(define-syntax the-polysemic-id (polysemic))
|
||||||
|
|
||||||
|
;; Record all known meanigns, so that the-case-dispatch-impl can perform some
|
||||||
|
;; sanity checks.
|
||||||
|
(begin-for-syntax
|
||||||
|
(define/contract all-meanings (set/c symbol? #:kind 'mutable) (mutable-set))
|
||||||
|
(define/contract (register-meanings-end syms)
|
||||||
|
(-> (listof symbol?) void?)
|
||||||
|
(for ([meaning (in-list syms)])
|
||||||
|
(set-add! all-meanings meaning)))
|
||||||
|
|
||||||
|
(define/contract (register-meanings syms)
|
||||||
|
(-> (listof symbol?) void?)
|
||||||
|
(for ([meaning (in-list syms)])
|
||||||
|
(set-add! all-meanings meaning))
|
||||||
|
(syntax-local-lift-module-end-declaration
|
||||||
|
#`(begin-for-syntax
|
||||||
|
(register-meanings-end '#,syms)))))
|
||||||
|
|
||||||
|
(begin-for-syntax
|
||||||
|
;; Represents a single overload of a function (function-id + predicate-id)
|
||||||
|
(struct a-case (f-id pred-id) #:transparent))
|
||||||
|
|
||||||
|
;; (FreeIdTable Id (Listof Id))
|
||||||
|
(define-for-syntax contracts-supertypes #f)
|
||||||
|
;; (FreeIdTable Id (Listof Id))
|
||||||
|
(define-for-syntax contracts-expand #f)
|
||||||
|
(define-for-syntax (detect-overlap stx pred-ids)
|
||||||
|
;; Lazily fill in the supertypes hash table, to avoid compile-time costs
|
||||||
|
;; when the module is later required.
|
||||||
|
(unless contracts-supertypes
|
||||||
|
(set! contracts-supertypes
|
||||||
|
(make-free-id-table
|
||||||
|
`((,#'any/c . ())
|
||||||
|
(,#'string? . (,#'any/c))
|
||||||
|
(,#'exact-positive-integer? . (,#'exact-integer? ,#'positive?))
|
||||||
|
(,#'exact-integer . (,#'integer? ,#'exact?))
|
||||||
|
(,#'integer? . (,#'number?))
|
||||||
|
(,#'exact? . (,#'number?)) ;; not quite right
|
||||||
|
(,#'number? . (,#'any/c))
|
||||||
|
(,#'zero? . (,#'integer?))
|
||||||
|
#;…))))
|
||||||
|
;; Lazily fill in the "expansion" hash table, to avoid compile-time costs
|
||||||
|
;; when the module is later required.
|
||||||
|
(unless contracts-expand
|
||||||
|
(set! contracts-expand
|
||||||
|
(make-free-id-table
|
||||||
|
`((,#'exact-nonnegative-integer? . (,#'zero?
|
||||||
|
,#'exact-positive-integer?))
|
||||||
|
#;…))))
|
||||||
|
;; Build the set of covered contracts. When a contract is a union of two
|
||||||
|
;; disjoint contracts, it is replaced by these
|
||||||
|
;; (e.g. exact-nonnegative-integer? is replaced by zero? and
|
||||||
|
;; exact-positive-integer?)
|
||||||
|
(define covered-ids (mutable-free-id-set))
|
||||||
|
(for/list ([pred-id (in-list pred-ids)])
|
||||||
|
(define expanded*
|
||||||
|
(free-id-table-ref contracts-expand
|
||||||
|
pred-id
|
||||||
|
(λ () (list pred-id))))
|
||||||
|
(for ([expanded (in-list expanded*)])
|
||||||
|
(when (free-id-set-member? covered-ids expanded)
|
||||||
|
(raise-syntax-error 'polysemy
|
||||||
|
"some available function cases overlap"
|
||||||
|
stx
|
||||||
|
#f
|
||||||
|
pred-ids))
|
||||||
|
(free-id-set-add! covered-ids expanded)))
|
||||||
|
;; Move up the inheritance DAG, and see if any of the ancestors
|
||||||
|
;; is covered. Since we start with the parents of the user-supplied contract,
|
||||||
|
;; there will be no self-detection.
|
||||||
|
(define already-recur (mutable-free-id-set))
|
||||||
|
(define (recur pred-id)
|
||||||
|
(unless (free-id-set-member? already-recur pred-id)
|
||||||
|
(free-id-set-add! already-recur pred-id)
|
||||||
|
(when (free-id-set-member? covered-ids pred-id)
|
||||||
|
(raise-syntax-error 'polysemy
|
||||||
|
"some available function cases overlap"
|
||||||
|
stx
|
||||||
|
#f
|
||||||
|
pred-ids))
|
||||||
|
(for-each recur (free-id-table-ref contracts-supertypes pred-id))))
|
||||||
|
(for ([pred-id (in-list pred-ids)])
|
||||||
|
(apply recur (free-id-table-ref contracts-supertypes
|
||||||
|
pred-id))))
|
||||||
|
|
||||||
|
(define-for-syntax (the-case-dispatch-impl stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(id . args)
|
||||||
|
(identifier? #'id)
|
||||||
|
#`(#%app #,(the-case-dispatch-impl #'id) . args)]
|
||||||
|
[id
|
||||||
|
(identifier? #'id)
|
||||||
|
(with-syntax
|
||||||
|
([((f-id pred-id) ...)
|
||||||
|
(for*/list ([meaning (in-set all-meanings)]
|
||||||
|
[generated-name (in-value (gen-id #'id meaning))]
|
||||||
|
[slv (in-value
|
||||||
|
(syntax-local-value generated-name (λ () #f)))]
|
||||||
|
#:when (and slv (a-case? slv)))
|
||||||
|
(list (a-case-f-id slv)
|
||||||
|
(a-case-pred-id slv)))])
|
||||||
|
;; Detect if there is overlap among the predicates, and raise an error
|
||||||
|
;; in that case.
|
||||||
|
(detect-overlap #'id (syntax->list #'(pred-id ...)))
|
||||||
|
;; TODO: for now, this only supports a single argument.
|
||||||
|
;; we should generalize it to support case-λ, and dispatch on
|
||||||
|
;; multiple arguments
|
||||||
|
;; TODO: use syntax-local-lift-module-end-declaration to cache
|
||||||
|
;; the generated dispatch functions.
|
||||||
|
#`(λ (arg)
|
||||||
|
(cond
|
||||||
|
[(pred-id arg) (f-id arg)]
|
||||||
|
...)))]))
|
||||||
|
|
||||||
|
;; The only case-dispatch macro (all others are renamings of this one)
|
||||||
|
(define-syntax the-case-dispatch the-case-dispatch-impl)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user