diff --git a/sugar/private/syntax-utils.rkt b/sugar/private/syntax-utils.rkt index 3e47666..0cd9d4f 100644 --- a/sugar/private/syntax-utils.rkt +++ b/sugar/private/syntax-utils.rkt @@ -16,14 +16,22 @@ ;; convert calling pattern to form (id contract body-exp) ;; hoist contract out of lambda-exp entirely (define-syntax-rule (lambdafy-with-contract stx) - (with-syntax ([(id (lambda args contract body-exp (... ...))) (let*-values ([(id-stx rhs-exp-stx) (normalize-definition stx (datum->syntax stx 'λ) #t #t)]) - (list id-stx (syntax->list rhs-exp-stx)))]) - ;; lambda-exp = #'(lambda args body-exp (... ...)) - #'(id contract (lambda args body-exp (... ...))))) + (syntax-case stx () + [(_ id contract lambda-exp) + ;; `normalize-definition` can't handle the `define/contract` pattern of three expressions after the `define`. + ;; so extract the contract, and then put id & lambda-exp back together, and let `normalize-definition` destructure as usual. + (with-syntax ([(new-id new-lambda-exp) (let-values ([(id-stx body-exp-stx) (normalize-definition #'(_ id lambda-exp) (datum->syntax stx 'λ) #t #t)]) + (list id-stx body-exp-stx))]) + #'(new-id contract new-lambda-exp))] + [else + (with-syntax ([(id (lambda args contract body-exp (... ...))) (let*-values ([(id-stx rhs-exp-stx) (normalize-definition stx (datum->syntax stx 'λ) #t #t)]) + (list id-stx (syntax->list rhs-exp-stx)))]) + ;; lambda-exp = #'(lambda args body-exp (... ...)) + #'(id contract (lambda args body-exp (... ...))))])) ;; convert calling pattern to form (id body-exp) (define-syntax-rule (lambdafy stx) (with-syntax ([(id lambda-exp) (let-values ([(id-stx body-exp-stx) (normalize-definition stx (datum->syntax stx 'λ) #t #t)]) - (list id-stx body-exp-stx))]) + (list id-stx body-exp-stx))]) #'(id lambda-exp))) \ No newline at end of file diff --git a/sugar/test/main.rkt b/sugar/test/main.rkt index d10b4b6..e779373 100644 --- a/sugar/test/main.rkt +++ b/sugar/test/main.rkt @@ -78,6 +78,18 @@ (check-equal? (safe:dps-f 1 #:y 0 2 3) 6) (check-exn exn:fail? (λ _ (safe:dps-f 'foo))) + (module dpsb racket/base + (require sugar/define) + (define+provide+safe dpsb-f + ((integer?) (#:y integer?) #:rest (listof integer?) . ->* . integer?) + (λ(x #:y [y 42] . zs) (apply + x y zs)))) + + (require 'dpsb) + (check-equal? (dpsb-f 1 #:y 0 2 3) 6) + (require (prefix-in safe: (submod 'dpsb safe))) + (check-equal? (safe:dpsb-f 1 #:y 0 2 3) 6) + (check-exn exn:fail? (λ _ (safe:dpsb-f 'foo))) + (module ps racket/base (require "../define.rkt") (provide+safe [ps-f ((integer?) (#:y integer?) #:rest (listof integer?) . ->* . integer?)])