-
Notifications
You must be signed in to change notification settings - Fork 0
/
csdoc.scm
140 lines (125 loc) · 4.04 KB
/
csdoc.scm
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
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
(module csdoc ()
(import chicken scheme)
(begin-for-syntax
(import chicken scheme)
(use srfi-1 srfi-69)
;; define storage for all documentation nodes
; root: The current node in the documentation tree we're working in
(define root '())
; nodes: A map of full paths to thier documentation nodes.
; a node is stored as an a-list.
(define nodes (make-hash-table #:test equal?))
;; helper functions
; returns the full path of a node specifier.
(define (as-node name)
(if (symbol? name)
(append root name)
name
)
)
; Expands a doc-string into CSDoc text-block format.
(define (expand-doc-text s)
(with-input-from-string s (lambda ()
(let (
(result '())
(current-string #f)
)
(port-for-each (lambda (c)
(if (eq? c #\@)
(begin
(when current-string
(set! result (cons current-string result))
(set! current-string #f)
)
(set! result (cons (read) result))
)
(begin
(unless current-string (set! current-string ""))
(set! current-string (string-append current-string (->string c)))
)
)
) read-char)
(when current-string
(set! result (cons current-string result))
)
(reverse result)
)
))
)
; Converts a list of keyword-value pairs into an alist. The key is the keyword, of #f for the unkeyworded args.
(define (keywords->alist args)
(let* (
(result `((#f)))
(rest (car result))
(kw #f)
)
(for-each (lambda (arg)
(if kw
(set! result (cons (cons kw arg) result))
(if (keyword? arg)
(set! kw arg)
(set-cdr! rest (cons arg (cdr rest)))
)
)
) args)
(set-cdr! rest (reverse (cdr rest)))
result
)
)
;; define handlers for the procedure `document`, handling the creation of new documentation nodes.
(define document-handlers (make-hash-table #:test eqv?))
; procedure: a procedure.
; Properties include:
; formals: A lambda-list, like the one you give to define to make a procedure.
; desc: A description of the function.
; args: A list of descriptions of the arguments.
; rets: A list of return values, in the order they are returned.
(hash-table-set! document-handlers 'procedure (lambda (rest)
(let* (
(formals (car rest))
(body (cdr rest))
(raw-name (car formals))
(name (if (symbol? raw-name) raw-name (last raw-name)))
(args (cdr formals))
(properties (keywords->alist body))
(positional-args (cdr (assq #f properties)))
(node `(procedure
(formals . ,formals)
(desc . ,(apply append (map expand-doc-text positional-args)))
(args . ())
(rets . ())
))
)
(hash-table-set! nodes (as-node raw-name) node)
)
))
;; workaround for issue #1465
(define (get-keyword kw args . default) (let (
(tail (memq kw args))
)
(if (and tail (not (null? (cdr tail))))
(cadr tail)
(if (null? default)
#f
((car default))
)
)
))
)
(export document)
(define-syntax document (er-macro-transformer (lambda (exp rename compare)
(let* (
(kind (cadr exp))
(rest (cddr exp))
(handler (hash-table-ref document-handlers kind))
)
(handler rest)
)
'(void)
)))
; TODO: will probably remove this later in favor of other ideas
(export docs-for)
(define-syntax docs-for (er-macro-transformer (lambda (exp rename compare)
`',(hash-table-ref/default nodes (cadr exp) #f)
)))
)