76 lines
2.6 KiB
Racket
76 lines
2.6 KiB
Racket
#lang racket/base
|
|
(require scribble/core
|
|
(for-syntax racket/base))
|
|
|
|
(provide cond-element
|
|
cond-block)
|
|
|
|
(define-for-syntax (render-cond stx mk check-result no-matching-case)
|
|
(syntax-case stx ()
|
|
[(_ [test body0 body ...] ...)
|
|
(let ([tests (syntax->list #'(test ...))])
|
|
(with-syntax ([(test-expr ...)
|
|
(for/list ([test (in-list tests)]
|
|
[pos (in-naturals)])
|
|
(let loop ([test test])
|
|
(syntax-case test (else and or not)
|
|
[else
|
|
(unless (= pos (sub1 (length tests)))
|
|
(raise-syntax-error
|
|
#f
|
|
"found `else' not in last clause"
|
|
stx
|
|
test))
|
|
#'#t]
|
|
[(and test ...)
|
|
#`(and . #,(map loop (syntax->list #'(test ...))))]
|
|
[(or test ...)
|
|
#`(or . #,(map loop (syntax->list #'(test ...))))]
|
|
[(not test)
|
|
#`(not #,(loop #'test))]
|
|
[id
|
|
(identifier? #'id)
|
|
#'(memq 'id mode)])))]
|
|
[mk mk]
|
|
[check-result check-result]
|
|
[no-matching-case no-matching-case])
|
|
#'(mk
|
|
(lambda (get put)
|
|
(let ([mode (get 'scribble:current-render-mode 'text)])
|
|
(cond
|
|
[test-expr (check-result (let () body0 body ...))]
|
|
...
|
|
[else (no-matching-case)]))))))]))
|
|
|
|
(define-syntax (cond-block stx)
|
|
(render-cond stx #'traverse-block #'check-block #'no-block-case))
|
|
|
|
(define-syntax (cond-element stx)
|
|
(render-cond stx #'traverse-element #'check-content #'no-element-case))
|
|
|
|
(define (check-block v)
|
|
(unless (block? v)
|
|
(raise-mismatch-error
|
|
'cond-block
|
|
"clause result is not a block: "
|
|
v))
|
|
v)
|
|
|
|
(define (check-content v)
|
|
(unless (content? v)
|
|
(raise-mismatch-error
|
|
'cond-element
|
|
"clause result is not content: "
|
|
v))
|
|
v)
|
|
|
|
(define (no-block-case)
|
|
(raise (make-exn:fail:contract
|
|
"cond-element: no clause matched"
|
|
(current-continuation-marks))))
|
|
|
|
(define (no-element-case)
|
|
(raise (make-exn:fail:contract
|
|
"cond-element: no clause matched"
|
|
(current-continuation-marks))))
|