-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathchez-docs.sls
223 lines (198 loc) · 8.71 KB
/
chez-docs.sls
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
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
(library (chez-docs)
(export doc
find-proc
launch-csug-summary)
(import (chezscheme))
;; setup --------------------------------------------------
;; https://gitlab.com/akkuscm/akku/-/issues/49#note_343046504
;; Chez has `include` so didn't need macro in GitLab issue example
;; `include` is much simpler than the hoops that I was jumping through previously
(include "summary-data.scm")
(include "chez-docs-data.scm")
;; many of these procedures use this data without it being explicitly passed
;; https://stackoverflow.com/questions/8382296/scheme-remove-duplicated-numbers-from-list
(define (remove-duplicates ls)
(cond [(null? ls)
'()]
[(member (car ls) (cdr ls))
(remove-duplicates (cdr ls))]
[else
(cons (car ls) (remove-duplicates (cdr ls)))]))
;; show documentation -----------------------------------------
(define doc
(case-lambda
[(proc) (doc-helper proc 'display 'both)]
[(proc action) (doc-helper proc action 'both)]
[(proc action source) (doc-helper proc action source)]))
(define (doc-helper proc action source)
(unless (string? proc)
(assertion-violation "(doc proc)" "proc is not a string"))
(unless (member action '(display open both))
(assertion-violation "(doc proc action)"
"action not one of 'display, 'open, 'both"))
(cond [(or (symbol=? source 'csug) (symbol=? source 'tspl))
(let ([doc (get-doc proc source)])
(if doc
(action-helper proc doc action source)
(assertion-violation "(doc proc action source)"
(string-append
proc " not found in "
(symbol->string source) "\n"
(guess-proc proc)))))]
[(symbol=? source 'both)
(let ([doc-csug (get-doc proc 'csug)]
[doc-tspl (get-doc proc 'tspl)])
(if (or doc-csug doc-tspl)
(begin
(when doc-csug (action-helper proc doc-csug action 'csug))
(when doc-tspl (action-helper proc doc-tspl action 'tspl)))
(assertion-violation "(doc proc)"
(string-append
proc " not found in csug or tspl\n"
(guess-proc proc)))))]
[else
(assertion-violation "(doc proc action source)"
"source not one of 'csug, 'tspl, 'both")]))
(define (action-helper proc doc action source)
(let ([srclu '((csug "\nCHEZ SCHEME USER'S GUIDE\n\n")
(tspl "\nTHE SCHEME PROGRAMMING LANGUAGE\n\n"))])
(when (not (symbol=? action 'open))
(display (cadr (assoc source srclu)))
(for-each display doc))
(when (not (symbol=? action 'display))
(launch-doc-link proc source))))
(define (get-doc proc source)
(let* ([anchor (get-anchor proc source)]
[src-data (cdr (assoc source chez-docs-data))]
[doc (assoc anchor src-data)])
(if doc (cdr doc) doc)))
(define (get-anchor proc source)
(let* ([src-data (cdr (assoc source summary-data))]
[row (assoc proc src-data)])
(if row (cadr row) row)))
(define (get-url proc source)
(let* ([src-data (cdr (assoc source summary-data))]
[row (assoc proc src-data)])
(if row (caddr row) row)))
(define (launch-doc-link proc source)
(launch-link
(get-url proc source)
"(doc proc action)"
"documentation"))
(define (launch-csug-summary)
(launch-link
"https://cisco.github.io/ChezScheme/csug10.0/summary.html"
"(launch-csug-summary)"
"CSUG summary"))
(define (launch-link url proc-string link-desc)
(if (not (string=? open-string "undefined"))
(system (string-append open-string url))
(assertion-violation
proc-string
(string-append
"open command not defined for this machine type\n"
link-desc " is at " url))))
(define open-string
(case (machine-type)
;; windows
[(i3nt ti3nt a6nt ta6nt arm64nt tarm64nt)
"start "]
;; mac
[(i3osx ti3osx a6osx ta6osx arm64osx tarm64osx ppc32osx tppc32osx)
"open "]
;; linux
[(i3le ti3le a6le ta6le arm64le tarm64le arm32le tarm32le
rv64le trv64le la64le tla64le ppc32le tppc32le)
"xdg-open "]
[else "undefined"]))
;; procedure search -----------------------------------------
;; extract unique list of "procedures" from data
(define proc-list
(sort string<?
(remove-duplicates
(append
(map car (cdr (assoc 'csug summary-data)))
(map car (cdr (assoc 'tspl summary-data)))))))
(define (guess-proc proc)
(string-append "Did you mean '" (car (find-proc proc 'fuzzy)) "'?"))
(define find-proc
(case-lambda
[(search-string)
(find-proc-helper search-string 'exact 10)]
[(search-string search-type)
(find-proc-helper search-string search-type 10)]
[(search-string search-type max-results)
(find-proc-helper search-string search-type max-results)]))
(define (find-proc-helper search-string search-type max-results)
(unless (string? search-string)
(assertion-violation "(find-proc search-string)" "search-string is not a string"))
(cond [(symbol=? search-type 'fuzzy)
(let* ([dist-list (map (lambda (x) (lev search-string x))
proc-list)]
[dist-proc (map (lambda (dist proc) (cons dist proc))
dist-list proc-list)]
[dist-proc-sort (sort (lambda (x y) (< (car x) (car y)))
dist-proc)])
(prepare-results dist-proc-sort search-type max-results))]
[(symbol=? search-type 'exact)
(let* ([bool-list (map (lambda (x) (string-match search-string x))
proc-list)]
[bool-proc (map (lambda (bool proc) (cons bool proc))
bool-list proc-list)]
[bool-proc-filter (filter (lambda (x) (car x)) bool-proc)])
(prepare-results bool-proc-filter search-type max-results))]
[else
(assertion-violation "(find-proc search-string search-type)"
"search-type must be either 'exact or 'fuzzy")]))
(define (prepare-results ls search-type max-results)
(let* ([len (length ls)]
[max-n (if (> max-results len) len max-results)])
(when (and (symbol=? search-type 'exact) (> len max-results))
(display (string-append "Returning " (number->string max-results)
" of " (number->string len)
" results\n")))
(map cdr (list-head ls max-n))))
(define (string-match s t)
(let* ([s-list (string->list s)]
[t-list (string->list t)])
(if (char=? (car s-list) #\^)
(string-match-helper (cdr s-list) t-list)
(not (for-all (lambda (x) (equal? x #f))
(map (lambda (t-sub) (string-match-helper s-list t-sub))
(potential-matches (car s-list) t-list)))))))
(define (string-match-helper s-list t-list)
(cond [(not t-list) #f]
[(null? s-list) #t]
[(< (length t-list) (length s-list)) #f]
[(char=? (car s-list) (car t-list))
(string-match-helper (cdr s-list) (cdr t-list))]
[else #f]))
(define (potential-matches char t-list)
(let loop ([t-list t-list]
[results '()])
(if (null? t-list)
(remove-duplicates (reverse results))
(loop (cdr t-list) (cons (member char t-list) results)))))
;; https://blogs.mathworks.com/cleve/2017/08/14/levenshtein-edit-distance-between-strings/
(define (lev s t)
(let* ([s (list->vector (string->list s))]
[t (list->vector (string->list t))]
[m (vector-length s)]
[n (vector-length t)]
[x (list->vector (iota (add1 n)))]
[y (list->vector (make-list (add1 n) 0))])
(do ((i 0 (add1 i)))
((= i m))
(vector-set! y 0 i)
(do ((j 0 (add1 j)))
((= j n))
(let ([c (if (char=? (vector-ref s i) (vector-ref t j)) 0 1)])
(vector-set! y (add1 j) (min (add1 (vector-ref y j))
(add1 (vector-ref x (add1 j)))
(+ c (vector-ref x j))))))
;; swap x and y
(let ([tmp x])
(set! x y)
(set! y tmp)))
(vector-ref x n)))
)