source: project/release/4/vandusen/trunk/vandusen-doc.scm

Last change on this file was 23386, checked in by Moritz Heidkamp, 10 years ago

vandusen: update chickadee uri

File size: 2.1 KB
Line 
1(module vandusen-doc ()
2
3(import chicken scheme data-structures srfi-1)
4(require-extension regex)
5(import irregex)
6(use vandusen chicken-doc uri-common srfi-18)
7
8(verify-repository)
9
10(define base-uri (uri-reference "http://api.call-cc.org/doc"))
11
12(define (format-results results)
13  (let* ((display-results (take results (min (length results) (or ($ 'doc-max-results) 5))))
14         (display-results (map (lambda (signature path)
15                                 (conc signature "  "
16                                       (uri->string (update-uri base-uri
17                                                                path: (append (uri-path base-uri)
18                                                                              (map symbol->string path))))))
19                               (map node-signature display-results)
20                               (map node-path display-results))))
21    (conc (string-intersperse display-results "\n")
22          (if (< (length display-results) (length results))
23              (format "\n(showing the first ~A of ~A results)"
24                      (length display-results)
25                      (length results))
26              ""))))
27
28(define (safe-call timeout thunk)
29  (let ((mutex (make-mutex))
30        (result (make-condition-variable)))
31    (mutex-lock! mutex)
32    (condition-case
33     (let ((thread (thread-start! 
34                    (lambda ()
35                      (condition-variable-specific-set! result (thunk))
36                      (condition-variable-signal! result)))))
37
38       (if (mutex-unlock! mutex result timeout)
39           (condition-variable-specific result)
40           (begin
41             (thread-terminate! thread)
42             (error "operation timed out"))))
43     (exn () exn))))
44
45(define (search-command search)
46  (lambda (message term)
47    (let ((results (safe-call (or ($ 'doc-search-timeout) 3) (cut search term))))
48      (reply-to message
49                (cond ((condition? results)
50                       (format "error: ~A" (get-condition-property results 'exn 'message)))
51                      ((null? results)
52                       (format "sorry, I couldn't find docs matching ~S" term))
53                      (else (format-results results)))
54                prefixed: #f))))
55
56(plugin 'doc
57        (lambda ()
58          (command 'doc
59                   '(: "doc" (+ space) (submatch (+ any)))
60                   (search-command match-nodes)
61                   public: #t)
62
63          (command 'wtf
64                   '(: "wtf" (+ space) (submatch (+ any)))
65                   (search-command (lambda (term) (match-nodes (irregex term))))
66                   public: #t))))
Note: See TracBrowser for help on using the repository browser.