diff --git a/main.rkt b/main.rkt index 0be9f50..3961b20 100644 --- a/main.rkt +++ b/main.rkt @@ -1,7 +1,7 @@ #lang racket/base (provide - ;; Another require transformer + ;; A require transformer poly-rename-in ;; Another require transformer poly-only-in @@ -57,25 +57,26 @@ (define-for-syntax (poly-require-transformer req stx) (syntax-parse stx [(_ mod - [old-id:id + [{~or {~and :id old-id new-id} + (old-id:id new-id:id)} meaning:id - {~optional new-id:id #:defaults ([new-id #'old-id])}] + ...] ...) - #:with (old-generated-id ...) - (map gen-id + #:with ((old-generated-id ...) ...) + (map (λ (id meanings) (map (λ (meaning) (gen-id id meaning)) meanings)) (syntax->list #'(old-id ...)) - (map syntax-e (syntax->list #'(meaning ...)))) + (map syntax-e (syntax->list #'((meaning ...) ...)))) #:with (new-generated-id ...) - (map gen-id + (map (λ (id meanings) (map (λ (meaning) (gen-id id meaning)) meanings)) (syntax->list #'(new-id ...)) - (map syntax-e (syntax->list #'(meaning ...)))) + (map syntax-e (syntax->list #'((meaning ...) ...)))) #:with (new-id-no-duplicates ...) (remove-duplicates (syntax->list #'(new-id ...)) free-identifier=?) #:with (new-safeguard-no-duplicates ...) (map (λ (one-id) (gen-id one-id '| safeguard |)) (syntax->list #'(new-id-no-duplicates ...))) - (register-meanings (syntax->datum #'(meaning ...))) + (register-meanings (syntax->datum #'(meaning ... ...))) (expand-import #`(combine-in ;; We always require the same ids, so that multiple requires @@ -83,7 +84,7 @@ (only-in polysemy/private/ids [the-polysemic-id new-id-no-duplicates] ... [the-safeguard-id new-safeguard-no-duplicates] ...) - (#,req mod [old-generated-id new-generated-id] ...)))])) + (#,req mod [old-generated-id new-generated-id] ... ...)))])) ;; Require transformer which allows renaming parts of polysemic identifiers. (define-syntax poly-rename-in @@ -177,12 +178,7 @@ (syntax-case stx () [(_ pvar meaning) ;; Do we need to (register-meanings #'(meaning)) here? I think not. - #'{~and {~var pvar (poly-stxclass 'meaning)}} - #;#'{~and {~var pvar id} - {~do (displayln #'pvar)} - {~bind [meaning-pvar - ]} - {~parse #t (not (not (attribute meaning-pvar)))}}]))))) + #'{~and {~var pvar (poly-stxclass 'meaning)}}]))))) (define-syntax-rule (define-poly-literal initial-id meaning syntax-class) (begin @@ -207,16 +203,27 @@ [(_ (name [arg₀ pred?] argᵢ ...) . body) (let ([meaning (string->symbol (format "~a" `(poly-case ,(syntax-e #'pred?))))]) - (with-syntax ([generated-name (gen-id #'name meaning)] - [generated-normal-macro (gen-id #'name 'normal-macro)]) + (with-syntax + ([generated-name (gen-id #'name meaning)] + [generated-normal-macro (gen-id #'name 'normal-macro)] + [generated-identifier-macro (gen-id #'name 'identifier-macro)]) (register-meanings `(,meaning)) #`(begin (define-poly name) + ;; TODO: provide keywords to selectively disable the + ;; identifier-macro or normal-macro behaviours. Also check that + ;; if identifier-binding does not return #f, it returns a binding + ;; for the-case-dispatch, and not for something else. #,@(if (identifier-binding #'generated-normal-macro) #'{} #'{(local-require (only-in polysemy [the-case-dispatch generated-normal-macro]))}) + #,@(if (identifier-binding #'generated-identifier-macro) + #'{} + #'{(local-require + (only-in polysemy + [the-case-dispatch generated-identifier-macro]))}) (define/contract (tmp-f arg₀ argᵢ ...) (-> pred? (or/c 'argᵢ any/c) ... any) . body) @@ -230,11 +237,12 @@ (unless contracts-supertypes (set! contracts-supertypes (make-free-id-table - `((,#'string? . (,#'any/c)) + `((,#'any/c . ()) + (,#'string? . (,#'any/c)) (,#'exact-positive-integer? . (,#'exact-integer? ,#'positive?)) (,#'exact-integer . (,#'integer? ,#'exact?)) (,#'integer? . (,#'number?)) - (,#'exact . (,#'number?)) ;; not quite right + (,#'exact? . (,#'number?)) ;; not quite right (,#'number? . (,#'any/c)) (,#'zero? . ,#'integer?) #;…)))) @@ -267,17 +275,20 @@ ;; 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) - (when (free-id-set-member? covered-ids 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)) - (unless (free-identifier=? pred-id #'any/c) - (for-each recur (free-id-table-ref contracts-supertypes pred-id '())))) + (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)))) + (apply recur (free-id-table-ref contracts-supertypes + pred-id)))) (define-for-syntax (the-case-dispatch-impl stx) (syntax-case stx () diff --git a/scribblings/polysemy.scrbl b/scribblings/polysemy.scrbl index 48f710c..8cd96d8 100644 --- a/scribblings/polysemy.scrbl +++ b/scribblings/polysemy.scrbl @@ -7,3 +7,100 @@ @defmodule[polysemy] +This is an experimental proof of concept, and is not intended to be used in +production until the potential issues of doing so have been discussed with +other racketeers. + +The bindings described here may be changed in future versions without notice. + +This module allows defining polysemic identifiers which can act as a +@tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{match expander}, +as a @tech[#:doc '(lib "scribblings/guide/guide.scrbl")]{macro}, as an +@tech[#:doc '(lib "scribblings/guide/guide.scrbl")]{identifier macro}, as a +@racket[set!] subform, and as a collection of + + +In all the forms below, the @racket[_meaning] should be a simple identifier. +Note that is lexical context is not taken into account (i.e. it is used as a +symbol), and therefore every @racket[_meaning] should be globally unique. +Later versions may add a notion of hygiene to meanings (allowing these +meanings themselves to be renamed, to circumvent conflicts). + +@defform[#:kind "require transformer" + (poly-only-in module [maybe-rename meaning ...] ...) + #:grammar [(maybe-rename old-id + [old-id new-id])]]{ + Requires each given @racket[meaning] of the corresponding @racket[old-id]. If + @racket[new-id] is supplied, then the meanings are attached to + @racket[new-id], otherwise they are attached to @racket[old-id].} + + +@defform[#:kind "require transformer" + (poly-rename-in module [maybe-rename meaning] ...) + #:grammar [(maybe-rename old-id + [old-id new-id])]]{ + + Similar to @racket[poly-only-in], but all identifiers and meanings which are + unaffected are also implicitly required. Note that if some (but not all) + meanings of an identifier are renamed, then the old name is not required + automatically anymore, and needs to be explicitly required.} + +@defform[#:kind "provide transformer" + (poly-out module [maybe-rename meaning]) + #:grammar [(maybe-rename old-id + [old-id new-id])]]{ + Provides the given meanings for @racket[id]. It is necessary to provide all + the desired meanings explicitly, or use @racket[(provide (all-defined-out))]. + Simply using @racket[(provide id)] will only provide the base identifier, + without any meanings attached to it. + + If @racket[old-id] and @racket[new-id] are supplied, each given + @racket[meaning], which must be attached to @racket[old-id], will be + re-attached to @racket[new-id].} + +@defform*[{(define-poly id) + (define-poly id meaning value)}]{ + The first form declares that @racket[id] is a polysemic identifier, with + no special meaning attached to it. + + The second form attaches the phase 1 @racket[value] (i.e. it is a transformer + value) to the given @racket[meaning] of the @racket[id].} + +@defform[#:kind "pattern expander" + (~poly pvar meaning)]{ + Pattern epander for @racketmodname[syntax/parse], can be used to match against + polysemic identifiers, extracting the desired @racket[meaning]. + + The transformer value for the requested meaning is stored in the + @racket[value] attribute.} + +@defform[(define-poly-literal id meaning syntax-class)]{ + Defines @racket[id] as a literal with the given @racket[meaning]. The + @racket[syntax-class] is automatically defined to recognise the given + @racket[meaning] of @racket[id], even if @racket[id] was renamed and its + different meanings split out and recombined into different identifiers.} + +@defform[(define-poly-case (name [arg₀ pred?] argᵢ ...) . body)]{ + Note that the syntax for this form will be changed in the future when support + for multiple-argument dispatch is added (remember, this package is still in an + experimental state). + + Defines an overload for the @racket[name] function, based on the type of its + first argument. For now, only a few contracts are allowed: + + @itemlist[ + @item[@racket[any/c]] + @item[@racket[string?]] + @item[@racket[exact-positive-integer?]] + @item[@racket[exact-integer]] + @item[@racket[integer?]] + @item[@racket[exact?]] + @item[@racket[number?]] + @item[@racket[zero?]]] + + When any polysemic identifier which is contains a poly-case is called as a + function, a check is performed to make sure that none of its cases overlap. If + some cases overlap, then an error is raised. + + Note that an identifier cannot have both a meaning as a function case, and a + @racket[normal-macro] or @racket[identifier-macro] meanings.} \ No newline at end of file