21cbd9ad81
and documented and adjusted these libraries:
racket/contract/base
racket/contract/exists
racket/contract/parametric (renamed from exists)
racket/contract/region
117 lines
4.7 KiB
Racket
117 lines
4.7 KiB
Racket
#lang racket/base
|
|
(require racket/contract/base
|
|
racket/contract/combinator
|
|
"../private/minimatch.rkt"
|
|
"../private/keywords.rkt"
|
|
"../private/runtime-reflect.rkt"
|
|
"../private/kws.rkt")
|
|
|
|
(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 fh cp success . rest2)
|
|
(let-values ([(kws kwargs) (merge2 kws1 kws2 kwargs1 kwargs2)])
|
|
(keyword-apply kws kwargs x cx pr es fh cp 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))
|
|
#:projection
|
|
(lambda (blame)
|
|
(let ([check-reified
|
|
((contract-projection
|
|
(or/c reified-syntax-class? reified-splicing-syntax-class?))
|
|
(blame-swap blame))])
|
|
(lambda (f)
|
|
(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) args)))
|
|
(raise-blame-error
|
|
blame
|
|
f
|
|
"expected a procedure of at least one argument, given ~e"
|
|
f)))))
|
|
#:first-order
|
|
(lambda (f)
|
|
(and (procedure? f) (procedure-arity-includes? f))))])
|
|
|