-
Notifications
You must be signed in to change notification settings - Fork 96
/
define-doc.rkt
83 lines (76 loc) · 3.12 KB
/
define-doc.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
#lang racket/base
(require (for-syntax racket/base
syntax/parse)
racket/contract/base
scribble/srcdoc
(for-doc scribble/eval))
(provide define/doc)
;; Both `proc-doc` and `proc-doc/names` can be verbose and repetitious.
;; Provide an alternative with approximately the same signature as `defproc`.
;; (Caveat: Can only express ->* contracts, not ->i or ->d.)
;;
;; Also, provide a way to list expressions that are used both as doc
;; examples and as unit tests.
(begin-for-syntax
(define-syntax-class required-argument
#:attributes (decl contract proc-doc)
(pattern [id:id c:expr]
#:with decl #'(id)
#:with contract #'(c)
#:with proc-doc #'id)
(pattern [kw:keyword id:id c:expr]
#:with decl #'(kw id)
#:with contract #'(kw c)
#:with proc-doc #'id))
(define-syntax-class optional-argument
#:attributes (decl contract proc-doc)
(pattern [id:id c:expr default:expr]
#:with decl #'((id default))
#:with contract #'(c)
#:with proc-doc #'(id default))
(pattern [kw:keyword id:id c:expr default:expr]
#:with decl #'(kw (id default))
#:with contract #'(kw c)
#:with proc-doc #'(id default)))
(define-splicing-syntax-class example/test
#:attributes (example test)
(pattern (~seq #:ex [actual:expr expected:expr])
#:with example #'actual
#:with test (syntax/loc #'actual ;helpful srcloc when tests fail
(check-equal? actual expected)))
;; This pattern is for example expressions like (require foo) that
;; aren't also a unit test.
(pattern (~seq #:ex [actual:expr])
#:with example #'actual
#:with test #'(begin))))
(define-syntax (define/doc stx)
(syntax-parse stx
[(_ (id:id req:required-argument ...
opt:optional-argument ...
result-contract:expr)
(doc-expr:expr ...)
et:example/test ...
body:expr ...+)
(with-syntax ([((req-decl ...) ...) #'(req.decl ...)]
[((opt-decl ...) ...) #'(opt.decl ...)]
[((req-contract ...) ...) #'(req.contract ...)]
[((opt-contract ...) ...) #'(opt.contract ...)]
[(doc-examples ...) (syntax-parse #'(et.example ...)
[() #'()] ;avoid (examples)
[(e:expr ...+) #'((examples e ...))])])
(syntax/loc stx
(begin
(define (id req-decl ... ...
opt-decl ... ...)
body ...)
(module+ test
(require rackunit)
et.test ...)
(provide
(proc-doc/names id
(->* (req-contract ... ...)
(opt-contract ... ...)
result-contract)
((req.proc-doc ...)
(opt.proc-doc ...))
(doc-expr ... doc-examples ...))))))]))