commit 9e3e2478bfa4e56acc4f8369ae206c3254578778
parent 92f18c3978111863419f9e624823940f6b0ad93b
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Tue, 9 May 2017 20:20:42 +0200
Moved the-case-dispatch to ids.rkt
Diffstat:
| M | main.rkt | | | 119 | +++---------------------------------------------------------------------------- |
| M | private/ids.rkt | | | 131 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- |
2 files changed, 134 insertions(+), 116 deletions(-)
diff --git a/main.rkt b/main.rkt
@@ -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)
diff --git a/private/ids.rkt b/private/ids.rkt
@@ -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)
