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

Moved the-case-dispatch to ids.rkt

Browse Source
This commit is contained in:
Georges Dupéron 2017-05-09 20:20:42 +02:00
parent 92f18c3978
commit 9e3e2478bf
2 changed files with 134 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

119
main.rkt
View File

@ -14,8 +14,6 @@
;; Defines a literal which can be renamed, without conflicting with other
;; poly literals, or identifiers with other meanings.
define-poly-literal
;; TODO: move this to ids.rkt
the-case-dispatch
;; Defines a static overload for a polysemic method
define-poly-case)
@ -34,21 +32,6 @@
racket/syntax)
(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
;; _____________________________________________________________________________
@ -196,9 +179,6 @@
; 'initial-id)
(pattern {~poly _ meaning})))))
(begin-for-syntax
(struct a-case (f-id pred-id) #:transparent))
;; TODO: multimethods
(define-syntax (define-poly-case stx)
(syntax-case stx ()
@ -219,106 +199,15 @@
#,@(if (identifier-binding #'generated-normal-macro)
#'{}
#'{(local-require
(only-in polysemy
(only-in polysemy/private/ids
[the-case-dispatch generated-normal-macro]))})
#,@(if (identifier-binding #'generated-identifier-macro)
#'{}
#'{(local-require
(only-in polysemy
[the-case-dispatch generated-identifier-macro]))})
(only-in polysemy/private/ids
[the-case-dispatch
generated-identifier-macro]))})
(define/contract (tmp-f arg₀ argᵢ ...)
(-> pred? (or/c 'argᵢ any/c) ... any)
. body)
(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
View File

@ -2,13 +2,26 @@
(require racket/match
(for-syntax racket/base
racket/contract
racket/set
syntax/id-table
syntax/id-set
"utils.rkt"))
(provide
;; The only polysemic id (all others are renamings of this one)
the-polysemic-id
;; 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
;; 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)
(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)