247 lines
11 KiB
Racket
247 lines
11 KiB
Racket
#lang racket/base
|
|
|
|
;; The provide form is at the bottom of the file, as it needs to use some
|
|
;; provide transformers defined within this file.
|
|
|
|
(require "private/ids.rkt"
|
|
racket/contract ;; TODO: remove if not needed.
|
|
(for-syntax racket/base
|
|
racket/list
|
|
racket/require-transform
|
|
racket/provide-transform
|
|
syntax/parse
|
|
"private/utils.rkt"
|
|
racket/contract)
|
|
(for-meta 2 racket/base))
|
|
|
|
;; Definition of polysemic identifiers and parts of these
|
|
;; _____________________________________________________________________________
|
|
|
|
(define-syntax (define-poly stx)
|
|
(syntax-case stx ()
|
|
;; Definition of a new polysemic identifier
|
|
[(_ id)
|
|
(with-syntax ([safeguard (gen-id #'id '| safeguard |)])
|
|
;; TODO: this won't handle local shadowings very well.
|
|
(if (and (identifier-binding #'id) (identifier-binding #'safeguard))
|
|
#'(begin)
|
|
#`(local-require
|
|
(only-in polysemy/private/ids
|
|
#,@(if (identifier-binding #'id)
|
|
#'{}
|
|
#'{[the-polysemic-id id]})
|
|
#,@(if (identifier-binding #'safeguard)
|
|
#'{}
|
|
#'{[the-safeguard-id safeguard]})))))]
|
|
;; Definition of a part of a (possibly new) polysemic identifier
|
|
[(_ id meaning value)
|
|
(with-syntax ([safeguard (gen-id #'id '| safeguard |)]
|
|
[generated-id (gen-id #'id (syntax-e #'meaning))])
|
|
(with-syntax ([define-meaning #'(define-syntax generated-id value)])
|
|
(register-meanings (syntax->datum #'(meaning)))
|
|
;; TODO: this won't handle local shadowings very well.
|
|
(if (and (identifier-binding #'id) (identifier-binding #'safeguard))
|
|
#'define-meaning
|
|
#'(begin
|
|
(define-poly id)
|
|
define-meaning))))]))
|
|
|
|
;; Syntax-parse pattern expander which extracts the given meaning from the
|
|
;; matched id
|
|
(begin-for-syntax
|
|
(define-syntax-class (poly-stxclass meaning)
|
|
#:attributes (value)
|
|
(pattern pvar:id
|
|
#:attr value (syntax-local-value (gen-id #'pvar meaning)
|
|
(λ () #f))
|
|
#:when (attribute value)))
|
|
(define-syntax ~poly
|
|
(pattern-expander
|
|
(λ (stx)
|
|
(syntax-case stx ()
|
|
[(_ pvar meaning)
|
|
;; Do we need to (register-meanings #'(meaning)) here? I think not.
|
|
#'{~and {~var pvar (poly-stxclass 'meaning)}}])))))
|
|
|
|
(define-syntax-rule (define-poly-literal initial-id meaning syntax-class)
|
|
(begin
|
|
(define-poly initial-id meaning
|
|
(λ (stx) (raise-syntax-error 'initial-id "reserved identifier" stx)))
|
|
(begin-for-syntax
|
|
(define-syntax-class syntax-class
|
|
#:attributes ()
|
|
;; TODO: the description is not present in error messages. Why ?
|
|
;#:description
|
|
;(format "the ~a meaning (originally bound to the ~a identifier)"
|
|
; 'meaning
|
|
; 'initial-id)
|
|
(pattern {~poly _ meaning})))))
|
|
|
|
;; TODO: multimethods
|
|
(define-syntax (define-poly-case stx)
|
|
(syntax-case stx ()
|
|
[(_ (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)]
|
|
[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/private/ids
|
|
[the-case-dispatch generated-normal-macro]))})
|
|
#,@(if (identifier-binding #'generated-identifier-macro)
|
|
#'{}
|
|
#'{(local-require
|
|
(only-in polysemy/private/ids
|
|
[the-case-dispatch
|
|
generated-identifier-macro]))})
|
|
(define/contract (tmp-f arg₀ argᵢ ...)
|
|
(-> pred? (or/c 'argᵢ 'TODO any/c) ... any)
|
|
. body)
|
|
(define-syntax generated-name (a-case #'tmp-f #'pred?)))))]))
|
|
|
|
;; Require/provide transformers
|
|
;; _____________________________________________________________________________
|
|
|
|
|
|
(begin-for-syntax
|
|
(define-syntax-class poly-meaning-expander-sc
|
|
#:attributes ([expanded 1])
|
|
(pattern {~poly x poly-reqprov-id-expander}
|
|
#:with (tmp:poly-meaning-expander-sc ...)
|
|
((attribute x.value) #'x)
|
|
#:with (expanded ...) #'(tmp.expanded ... ...))
|
|
(pattern x:id #:with (expanded ...) #'(x))
|
|
(pattern {~and whole ({~poly x poly-meaning-expander} . _)}
|
|
#:with (tmp:poly-meaning-expander-sc ...)
|
|
((attribute x.value) #'whole)
|
|
#:with (expanded ...) #'(tmp.expanded ... ...))))
|
|
(define-poly case-function poly-meaning-expander
|
|
(λ (stx)
|
|
(syntax-case stx ()
|
|
;; TODO: make the normal-macro and identifier-macro switchable.
|
|
[(_ pred?) #`(normal-macro
|
|
identifier-macro
|
|
#,(string->symbol
|
|
(format "~a" `(poly-case ,(syntax-e #'pred?)))))])))
|
|
|
|
;; Require transformers
|
|
;; _____________________________________________________________________________
|
|
|
|
;; Common implementation for the poly-rename-in and poly-only-in rename
|
|
;; transformers.
|
|
(define-for-syntax (poly-require-transformer req stx)
|
|
(syntax-parse stx
|
|
[(_ mod
|
|
[{~or {~and :id old-id new-id} (old-id:id new-id:id)}
|
|
meaning:poly-meaning-expander-sc
|
|
...]
|
|
...)
|
|
#:with ((old-generated-id ...) ...)
|
|
(map (λ (id meanings)
|
|
(map (λ (meaning) (gen-id id (syntax-e meaning)))
|
|
(remove-duplicates (syntax->list meanings) free-identifier=?)))
|
|
(syntax->list #'(old-id ...))
|
|
(syntax->list #'((meaning.expanded ... ...) ...)))
|
|
#:with ((new-generated-id ...) ...)
|
|
(map (λ (id meanings)
|
|
(map (λ (meaning) (gen-id id (syntax-e meaning)))
|
|
(remove-duplicates (syntax->list meanings) free-identifier=?)))
|
|
(syntax->list #'(new-id ...))
|
|
(syntax->list #'((meaning.expanded ... ...) ...)))
|
|
#: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.expanded ... ... ...)))
|
|
(expand-import
|
|
#`(combine-in
|
|
;; We always require the same ids, so that multiple requires
|
|
;; are a no-op, instead of causing conflicts.
|
|
(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] ... ...)))]))
|
|
|
|
;; Require transformer which allows renaming parts of polysemic identifiers.
|
|
(define-syntax poly-rename-in
|
|
(make-require-transformer
|
|
(λ (stx) (poly-require-transformer #'rename-in stx))))
|
|
|
|
;; Require transformer which allows selecting and renaming parts of polysemic
|
|
;; identifiers.
|
|
(define-syntax poly-only-in
|
|
(make-require-transformer
|
|
(λ (stx) (poly-require-transformer #'only-in stx))))
|
|
|
|
;; Provide transformer
|
|
;; _____________________________________________________________________________
|
|
|
|
(define-syntax poly-out
|
|
(make-provide-pre-transformer
|
|
(λ (provide-spec modes)
|
|
(syntax-parse provide-spec
|
|
[(_ [{~or {~and :id old-id new-id} (old-id:id new-id:id)}
|
|
meaning:poly-meaning-expander-sc ...]
|
|
...)
|
|
(with-syntax ([((old-generated-id ...) ...)
|
|
(map (λ (one-id meanings)
|
|
(map (λ (one-meaning)
|
|
(gen-id one-id (syntax-e one-meaning)))
|
|
(remove-duplicates (syntax->list meanings)
|
|
free-identifier=?)))
|
|
(syntax->list #'(old-id ...))
|
|
(syntax->list #'((meaning.expanded ... ...) ...)))]
|
|
[((new-generated-id ...) ...)
|
|
(map (λ (one-id meanings)
|
|
(map (λ (one-meaning)
|
|
(gen-id one-id (syntax-e one-meaning)))
|
|
(remove-duplicates (syntax->list meanings)
|
|
free-identifier=?)))
|
|
(syntax->list #'(new-id ...))
|
|
(syntax->list #'((meaning.expanded ... ...) ...)))]
|
|
[(old-safeguard ...)
|
|
(map (λ (one-id) (gen-id one-id '| safeguard |))
|
|
(syntax->list #'(old-id ...)))]
|
|
[(new-safeguard ...)
|
|
(map (λ (one-id) (gen-id one-id '| safeguard |))
|
|
(syntax->list #'(new-id ...)))])
|
|
(register-meanings (syntax->datum #'(meaning.expanded ... ... ...)))
|
|
(pre-expand-export #'(rename-out [old-safeguard new-safeguard] ...
|
|
[old-id new-id] ...
|
|
[old-generated-id new-generated-id]
|
|
... ...)
|
|
modes))]))))
|
|
|
|
(provide
|
|
;; A require transformer
|
|
poly-rename-in
|
|
;; Another require transformer
|
|
poly-only-in
|
|
;; Provide transformer
|
|
poly-out
|
|
;; Definition of a polysemic id, and of a part of a polysemic id
|
|
define-poly
|
|
;; Syntax-parse pattern expander which extracts the given meaning from the id
|
|
(for-syntax ~poly)
|
|
;; Defines a literal which can be renamed, without conflicting with other
|
|
;; poly literals, or identifiers with other meanings.
|
|
define-poly-literal
|
|
;; Defines a static overload for a polysemic method
|
|
define-poly-case
|
|
;; Syntactic token used to build case-function meanings
|
|
;; TODO: We probably should make it a case-function-expander instead of a token
|
|
(poly-out [case-function poly-meaning-expander]))
|