57 lines
2.1 KiB
Racket
57 lines
2.1 KiB
Racket
#lang racket
|
|
|
|
(require (for-template racket/base racket/contract))
|
|
|
|
(define (parse-kw-args formals actuals source form-name)
|
|
(let loop ([current (for/hash ([arg formals]) (values (car arg) #f))]
|
|
[rest actuals])
|
|
(syntax-case rest ()
|
|
[() (map (λ (arg)
|
|
(match (hash-ref current (car arg))
|
|
[#f (cadr arg)]
|
|
[x (match (cdr (cdr arg))
|
|
['() x]
|
|
[`((,ctc ,desc))
|
|
(apply-contract ctc x desc form-name)])]))
|
|
formals)]
|
|
[(kw . rest)
|
|
(not (keyword? (syntax-e (syntax kw))))
|
|
(raise-syntax-error #f "expected a keyword" source (syntax kw))]
|
|
[(kw arg . rest)
|
|
(keyword? (syntax-e (syntax arg)))
|
|
(raise-syntax-error #f "expected an argument expression" source (syntax arg))]
|
|
[(kw arg . rest)
|
|
(let ([none (gensym)])
|
|
(eq? none (hash-ref current (syntax-e (syntax kw)) none)))
|
|
(raise-syntax-error #f "invalid keyword" source (syntax kw))]
|
|
[(kw arg . rest)
|
|
(hash-ref current (syntax-e (syntax kw)))
|
|
(raise-syntax-error #f "repeated keyword" source (syntax kw))]
|
|
[(kw)
|
|
(raise-syntax-error #f "missing argument expression after keyword" source (syntax kw))]
|
|
[(kw arg . rest)
|
|
(loop (hash-set current (syntax-e (syntax kw)) (syntax arg))
|
|
(syntax rest))]
|
|
[else (raise-syntax-error #f "bad keyword argument syntax" source rest)])))
|
|
|
|
(define (client-name stx form)
|
|
(let ([m (syntax-source-module stx)])
|
|
(cond [(module-path-index? m)
|
|
(format "~a" (module-path-index-resolve m))]
|
|
[(or (symbol? m) (path? m))
|
|
(format "~a" m)]
|
|
[else (format "~s client" form)])))
|
|
|
|
(define (src-loc-stx stx)
|
|
#`#(#,(syntax-source stx)
|
|
#,(syntax-line stx)
|
|
#,(syntax-column stx)
|
|
#,(syntax-position stx)
|
|
#,(syntax-span stx)))
|
|
|
|
(define (apply-contract ctc expr desc form)
|
|
#`(contract #,ctc #,expr
|
|
#,(client-name expr form) '#,form
|
|
#,desc #,(src-loc-stx expr)))
|
|
|
|
(provide (all-defined-out)) |