Added documentation
This commit is contained in:
parent
eccf84b899
commit
a2c817c7cd
57
main.rkt
57
main.rkt
|
@ -1,7 +1,7 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(provide
|
(provide
|
||||||
;; Another require transformer
|
;; A require transformer
|
||||||
poly-rename-in
|
poly-rename-in
|
||||||
;; Another require transformer
|
;; Another require transformer
|
||||||
poly-only-in
|
poly-only-in
|
||||||
|
@ -57,25 +57,26 @@
|
||||||
(define-for-syntax (poly-require-transformer req stx)
|
(define-for-syntax (poly-require-transformer req stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ mod
|
[(_ mod
|
||||||
[old-id:id
|
[{~or {~and :id old-id new-id}
|
||||||
|
(old-id:id new-id:id)}
|
||||||
meaning:id
|
meaning:id
|
||||||
{~optional new-id:id #:defaults ([new-id #'old-id])}]
|
...]
|
||||||
...)
|
...)
|
||||||
#:with (old-generated-id ...)
|
#:with ((old-generated-id ...) ...)
|
||||||
(map gen-id
|
(map (λ (id meanings) (map (λ (meaning) (gen-id id meaning)) meanings))
|
||||||
(syntax->list #'(old-id ...))
|
(syntax->list #'(old-id ...))
|
||||||
(map syntax-e (syntax->list #'(meaning ...))))
|
(map syntax-e (syntax->list #'((meaning ...) ...))))
|
||||||
#:with (new-generated-id ...)
|
#:with (new-generated-id ...)
|
||||||
(map gen-id
|
(map (λ (id meanings) (map (λ (meaning) (gen-id id meaning)) meanings))
|
||||||
(syntax->list #'(new-id ...))
|
(syntax->list #'(new-id ...))
|
||||||
(map syntax-e (syntax->list #'(meaning ...))))
|
(map syntax-e (syntax->list #'((meaning ...) ...))))
|
||||||
#:with (new-id-no-duplicates ...)
|
#:with (new-id-no-duplicates ...)
|
||||||
(remove-duplicates (syntax->list #'(new-id ...))
|
(remove-duplicates (syntax->list #'(new-id ...))
|
||||||
free-identifier=?)
|
free-identifier=?)
|
||||||
#:with (new-safeguard-no-duplicates ...)
|
#:with (new-safeguard-no-duplicates ...)
|
||||||
(map (λ (one-id) (gen-id one-id '| safeguard |))
|
(map (λ (one-id) (gen-id one-id '| safeguard |))
|
||||||
(syntax->list #'(new-id-no-duplicates ...)))
|
(syntax->list #'(new-id-no-duplicates ...)))
|
||||||
(register-meanings (syntax->datum #'(meaning ...)))
|
(register-meanings (syntax->datum #'(meaning ... ...)))
|
||||||
(expand-import
|
(expand-import
|
||||||
#`(combine-in
|
#`(combine-in
|
||||||
;; We always require the same ids, so that multiple requires
|
;; We always require the same ids, so that multiple requires
|
||||||
|
@ -83,7 +84,7 @@
|
||||||
(only-in polysemy/private/ids
|
(only-in polysemy/private/ids
|
||||||
[the-polysemic-id new-id-no-duplicates] ...
|
[the-polysemic-id new-id-no-duplicates] ...
|
||||||
[the-safeguard-id new-safeguard-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.
|
;; Require transformer which allows renaming parts of polysemic identifiers.
|
||||||
(define-syntax poly-rename-in
|
(define-syntax poly-rename-in
|
||||||
|
@ -177,12 +178,7 @@
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ pvar meaning)
|
[(_ pvar meaning)
|
||||||
;; Do we need to (register-meanings #'(meaning)) here? I think not.
|
;; Do we need to (register-meanings #'(meaning)) here? I think not.
|
||||||
#'{~and {~var pvar (poly-stxclass 'meaning)}}
|
#'{~and {~var pvar (poly-stxclass 'meaning)}}])))))
|
||||||
#;#'{~and {~var pvar id}
|
|
||||||
{~do (displayln #'pvar)}
|
|
||||||
{~bind [meaning-pvar
|
|
||||||
]}
|
|
||||||
{~parse #t (not (not (attribute meaning-pvar)))}}])))))
|
|
||||||
|
|
||||||
(define-syntax-rule (define-poly-literal initial-id meaning syntax-class)
|
(define-syntax-rule (define-poly-literal initial-id meaning syntax-class)
|
||||||
(begin
|
(begin
|
||||||
|
@ -207,16 +203,27 @@
|
||||||
[(_ (name [arg₀ pred?] argᵢ ...) . body)
|
[(_ (name [arg₀ pred?] argᵢ ...) . body)
|
||||||
(let ([meaning (string->symbol
|
(let ([meaning (string->symbol
|
||||||
(format "~a" `(poly-case ,(syntax-e #'pred?))))])
|
(format "~a" `(poly-case ,(syntax-e #'pred?))))])
|
||||||
(with-syntax ([generated-name (gen-id #'name meaning)]
|
(with-syntax
|
||||||
[generated-normal-macro (gen-id #'name 'normal-macro)])
|
([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))
|
(register-meanings `(,meaning))
|
||||||
#`(begin
|
#`(begin
|
||||||
(define-poly name)
|
(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)
|
#,@(if (identifier-binding #'generated-normal-macro)
|
||||||
#'{}
|
#'{}
|
||||||
#'{(local-require
|
#'{(local-require
|
||||||
(only-in polysemy
|
(only-in polysemy
|
||||||
[the-case-dispatch generated-normal-macro]))})
|
[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ᵢ ...)
|
(define/contract (tmp-f arg₀ argᵢ ...)
|
||||||
(-> pred? (or/c 'argᵢ any/c) ... any)
|
(-> pred? (or/c 'argᵢ any/c) ... any)
|
||||||
. body)
|
. body)
|
||||||
|
@ -230,11 +237,12 @@
|
||||||
(unless contracts-supertypes
|
(unless contracts-supertypes
|
||||||
(set! contracts-supertypes
|
(set! contracts-supertypes
|
||||||
(make-free-id-table
|
(make-free-id-table
|
||||||
`((,#'string? . (,#'any/c))
|
`((,#'any/c . ())
|
||||||
|
(,#'string? . (,#'any/c))
|
||||||
(,#'exact-positive-integer? . (,#'exact-integer? ,#'positive?))
|
(,#'exact-positive-integer? . (,#'exact-integer? ,#'positive?))
|
||||||
(,#'exact-integer . (,#'integer? ,#'exact?))
|
(,#'exact-integer . (,#'integer? ,#'exact?))
|
||||||
(,#'integer? . (,#'number?))
|
(,#'integer? . (,#'number?))
|
||||||
(,#'exact . (,#'number?)) ;; not quite right
|
(,#'exact? . (,#'number?)) ;; not quite right
|
||||||
(,#'number? . (,#'any/c))
|
(,#'number? . (,#'any/c))
|
||||||
(,#'zero? . ,#'integer?)
|
(,#'zero? . ,#'integer?)
|
||||||
#;…))))
|
#;…))))
|
||||||
|
@ -267,17 +275,20 @@
|
||||||
;; Move up the inheritance DAG, and see if any of the ancestors
|
;; 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,
|
;; is covered. Since we start with the parents of the user-supplied contract,
|
||||||
;; there will be no self-detection.
|
;; there will be no self-detection.
|
||||||
|
(define already-recur (mutable-free-id-set))
|
||||||
(define (recur pred-id)
|
(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)
|
(when (free-id-set-member? covered-ids pred-id)
|
||||||
(raise-syntax-error 'polysemy
|
(raise-syntax-error 'polysemy
|
||||||
"some available function cases overlap"
|
"some available function cases overlap"
|
||||||
stx
|
stx
|
||||||
#f
|
#f
|
||||||
pred-ids))
|
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)])
|
(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)
|
(define-for-syntax (the-case-dispatch-impl stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
|
|
|
@ -7,3 +7,100 @@
|
||||||
|
|
||||||
@defmodule[polysemy]
|
@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.}
|
Loading…
Reference in New Issue
Block a user