150 lines
6.4 KiB
Racket
150 lines
6.4 KiB
Racket
#lang racket/base
|
|
(require (for-syntax racket/base
|
|
racket/lazy-require
|
|
racket/syntax
|
|
syntax/parse/private/residual-ct) ;; keep abs.path
|
|
racket/contract/base
|
|
racket/contract/combinator
|
|
syntax/parse/private/minimatch
|
|
syntax/parse/private/keywords
|
|
"../private/runtime-reflect.rkt"
|
|
syntax/parse/private/kws)
|
|
(begin-for-syntax
|
|
(lazy-require
|
|
[syntax/parse/private/rep-data ;; keep abs. path
|
|
(get-stxclass)]))
|
|
;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require)
|
|
;; Without this, dependencies don't get collected.
|
|
(require racket/runtime-path (for-meta 2 '#%kernel))
|
|
(define-runtime-module-path-index _unused_ 'syntax/parse/private/rep-data)
|
|
|
|
(define-syntax (reify-syntax-class stx)
|
|
(if (eq? (syntax-local-context) 'expression)
|
|
(syntax-case stx ()
|
|
[(rsc sc)
|
|
(with-disappeared-uses
|
|
(let* ([stxclass (get-stxclass #'sc)]
|
|
[splicing? (stxclass-splicing? stxclass)])
|
|
(unless (scopts-delimit-cut? (stxclass-opts stxclass))
|
|
(raise-syntax-error #f "cannot reify syntax class with #:no-delimit-cut option"
|
|
stx #'sc))
|
|
(with-syntax ([name (stxclass-name stxclass)]
|
|
[parser (stxclass-parser stxclass)]
|
|
[arity (stxclass-arity stxclass)]
|
|
[(#s(attr aname adepth _) ...) (stxclass-attrs stxclass)]
|
|
[ctor
|
|
(if splicing?
|
|
#'reified-splicing-syntax-class
|
|
#'reified-syntax-class)])
|
|
#'(ctor 'name parser 'arity '((aname adepth) ...)))))])
|
|
#`(#%expression #,stx)))
|
|
|
|
(define (reified-syntax-class-arity r)
|
|
(match (reified-arity r)
|
|
[(arity minpos maxpos _ _)
|
|
(to-procedure-arity minpos maxpos)]))
|
|
|
|
(define (reified-syntax-class-keywords r)
|
|
(match (reified-arity r)
|
|
[(arity _ _ minkws maxkws)
|
|
(values minkws maxkws)]))
|
|
|
|
(define (reified-syntax-class-attributes r)
|
|
(reified-signature r))
|
|
|
|
(define reified-syntax-class-curry
|
|
(make-keyword-procedure
|
|
(lambda (kws1 kwargs1 r . rest1)
|
|
(match r
|
|
[(reified name parser arity1 sig)
|
|
(let ()
|
|
(check-curry arity1 (length rest1) kws1
|
|
(lambda (msg)
|
|
(raise-mismatch-error 'reified-syntax-class-curry
|
|
(string-append msg ": ") r)))
|
|
(let* ([curried-arity
|
|
(match arity1
|
|
[(arity minpos maxpos minkws maxkws)
|
|
(let* ([rest1-length (length rest1)]
|
|
[minpos* (- minpos rest1-length)]
|
|
[maxpos* (- maxpos rest1-length)]
|
|
[minkws* (sort (remq* kws1 minkws) keyword<?)]
|
|
[maxkws* (sort (remq* kws1 maxkws) keyword<?)])
|
|
(arity minpos* maxpos* minkws* maxkws*))])]
|
|
[curried-parser
|
|
(make-keyword-procedure
|
|
(lambda (kws2 kwargs2 x cx pr es undos fh cp rl success . rest2)
|
|
(let-values ([(kws kwargs) (merge2 kws1 kws2 kwargs1 kwargs2)])
|
|
(keyword-apply parser kws kwargs x cx pr es undos fh cp rl success
|
|
(append rest1 rest2)))))]
|
|
[ctor
|
|
(cond [(reified-syntax-class? r)
|
|
reified-syntax-class]
|
|
[(reified-splicing-syntax-class? r)
|
|
reified-splicing-syntax-class]
|
|
[else
|
|
(error 'curry-reified-syntax-class "INTERNAL ERROR: ~e" r)])])
|
|
(ctor name curried-parser curried-arity sig)))]))))
|
|
|
|
(define (merge2 kws1 kws2 kwargs1 kwargs2)
|
|
(cond [(null? kws1)
|
|
(values kws2 kwargs2)]
|
|
[(null? kws2)
|
|
(values kws1 kwargs1)]
|
|
[(keyword<? (car kws1) (car kws2))
|
|
(let-values ([(m-kws m-kwargs)
|
|
(merge2 (cdr kws1) kws2 (cdr kwargs1) kwargs2)])
|
|
(values (cons (car kws1) m-kws) (cons (car kwargs1) m-kwargs)))]
|
|
[else
|
|
(let-values ([(m-kws m-kwargs)
|
|
(merge2 kws1 (cdr kws2) kwargs1 (cdr kwargs2))])
|
|
(values (cons (car kws2) m-kws) (cons (car kwargs2) m-kwargs)))]))
|
|
|
|
;; ----
|
|
|
|
(provide reify-syntax-class
|
|
~reflect
|
|
~splicing-reflect)
|
|
|
|
(provide/contract
|
|
[reified-syntax-class?
|
|
(-> any/c boolean?)]
|
|
[reified-splicing-syntax-class?
|
|
(-> any/c boolean?)]
|
|
[reified-syntax-class-attributes
|
|
(-> (or/c reified-syntax-class? reified-splicing-syntax-class?)
|
|
(listof (list/c symbol? exact-nonnegative-integer?)))]
|
|
[reified-syntax-class-arity
|
|
(-> (or/c reified-syntax-class? reified-splicing-syntax-class?)
|
|
procedure-arity?)]
|
|
[reified-syntax-class-keywords
|
|
(-> (or/c reified-syntax-class? reified-splicing-syntax-class?)
|
|
(values (listof keyword?)
|
|
(listof keyword?)))]
|
|
[reified-syntax-class-curry
|
|
(make-contract #:name '(->* ((or/c reified-syntax-class? reified-splicing-syntax-class/c))
|
|
(#:<kw> any/c ...)
|
|
#:rest list?
|
|
(or/c reified-syntax-class? reified-splicing-syntax-class/c))
|
|
#:late-neg-projection
|
|
(lambda (blame)
|
|
(let ([check-reified
|
|
((contract-late-neg-projection
|
|
(or/c reified-syntax-class? reified-splicing-syntax-class?))
|
|
(blame-swap blame))])
|
|
(lambda (f neg-party)
|
|
(if (and (procedure? f)
|
|
(procedure-arity-includes? f 1))
|
|
(make-keyword-procedure
|
|
(lambda (kws kwargs r . args)
|
|
(keyword-apply f kws kwargs (check-reified r neg-party) args)))
|
|
(raise-blame-error
|
|
blame #:missing-party neg-party
|
|
f
|
|
"expected a procedure of at least one argument, given ~e"
|
|
f)))))
|
|
#:first-order
|
|
(lambda (f)
|
|
(and (procedure? f) (procedure-arity-includes? f))))])
|
|
|