From 315d87174c825c803eff3029c9ecf352f62c1acf Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 30 Apr 2015 08:54:11 +0900 Subject: [PATCH] Improving automated "optionals" signature extraction in (chibi doc). --- lib/chibi/doc-test.sld | 13 +++++++++++++ lib/chibi/doc.scm | 30 ++++++++++++++++++++---------- lib/chibi/doc.sld | 3 ++- tests/lib-tests.scm | 2 ++ 4 files changed, 37 insertions(+), 11 deletions(-) create mode 100644 lib/chibi/doc-test.sld diff --git a/lib/chibi/doc-test.sld b/lib/chibi/doc-test.sld new file mode 100644 index 00000000..bee75215 --- /dev/null +++ b/lib/chibi/doc-test.sld @@ -0,0 +1,13 @@ +(define-library (chibi doc-test) + (export run-tests) + (import (scheme base) (chibi doc) (chibi test)) + (begin + (define (run-tests) + (test-begin "doc") + (test '(spec (args config)) + (get-optionals-signature + '(spec . o) + '(let ((args (or (and (pair? o) (car o)) (command-line))) + (config (and (pair? o) (pair? (cdr o)) (cadr o)))) + (foo)))) + (test-end)))) diff --git a/lib/chibi/doc.scm b/lib/chibi/doc.scm index 93082730..8daa96c1 100644 --- a/lib/chibi/doc.scm +++ b/lib/chibi/doc.scm @@ -476,7 +476,7 @@ div#footer {padding-bottom: 50px} ;; Try to determine the names of optional parameters checking common ;; patterns. -(define (get-optionals ls body) +(define (get-optionals-signature ls body) (let lp ((ls ls) (pre '())) (cond ((pair? ls) (lp (cdr ls) (cons (car ls) pre))) @@ -492,30 +492,37 @@ div#footer {padding-bottom: 50px} (if (contains? val o) (extract #f vars i) (extract rest vars i))) - ((((or 'let 'let* 'letrec 'letrec*) (y ...) . body)) + (((or 'let 'let* 'letrec 'letrec*) (y ...) . body) (let ((ordered? (memq (car x) '(let* letrec*)))) (let lp ((ls y) (vars vars) (j i)) (cond ((pair? ls) (match (car ls) + ;; handle rebinding o (((? o?) ('if ('pair? (? o?)) ('cdr (? o?)) default)) (lp (cdr ls) vars (+ j 1))) (((? o?) expr) (extract #f vars i)) + ;; binding vars to o ((v ('if ('pair? (? o?)) ('car (? o?)) default)) (lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j)) ((v ('and ('pair? (? o?)) ('car (? o?)))) (lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j)) + ((v ('or ('and ('pair? (? o?)) ('car (? o?))) default)) + (lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j)) ((v ('if ('and ('pair? (? o?)) ('pair? ('cdr (? o?)))) ('cadr (? o?)) default)) (lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j)) + ((v ('and ('pair? (? o?)) ('pair? ('cdr (? o?))) + ('cadr (? o?)))) + (lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j)) (else (lp (cdr ls) vars j)))) (else (extract body vars j)))))) - ((((or 'let-optionals 'let-optionals*) ls ((var default) ...) - . body)) + (((or 'let-optionals 'let-optionals*) ls ((var default) ...) + . body) (let lp ((ls var) (vars vars) (i i)) (cond ((pair? ls) @@ -524,15 +531,17 @@ div#footer {padding-bottom: 50px} (extract body vars i))))) (else (let ((opts (map car (sort vars < cdr))) - (dotted? (contains? x o))) + (rest-var? (contains? x o))) (append (reverse pre) (cond - ((and (pair? opts) dotted?) + ((and (pair? opts) rest-var?) (list (append opts o))) - (dotted? + (rest-var? o) + ((pair? opts) + (list opts)) (else - (list opts))))))))))))) + '())))))))))))) (define (get-procedure-signature mod id proc) (cond ((and mod (procedure? proc) (procedure-signature id mod)) @@ -544,7 +553,8 @@ div#footer {padding-bottom: 50px} (match value (('(or let let* letrec letrec*) vars body0 ... body) (get-value-signature mod id proc name body)) - (('lambda args . body) (list (cons name (get-optionals args body)))) + (('lambda args . body) + (list (cons name (get-optionals-signature args body)))) ((('lambda args body0 ... body) vals ...) (get-value-signature mod id proc name body)) (('begin body0 ... body) (get-value-signature mod id proc name body)) @@ -557,7 +567,7 @@ div#footer {padding-bottom: 50px} (('define (name args ...) . body) (list (cons name args))) (('define (name . args) . body) - (list (cons name (get-optionals args body)))) + (list (cons name (get-optionals-signature args body)))) (('define name value) (get-value-signature mod id proc name value)) (('define-syntax name ('syntax-rules () (clause . body) ...)) diff --git a/lib/chibi/doc.sld b/lib/chibi/doc.sld index 3fdd4885..4192db86 100644 --- a/lib/chibi/doc.sld +++ b/lib/chibi/doc.sld @@ -10,5 +10,6 @@ print-module-docs print-module-binding-docs generate-docs expand-docs fixup-docs extract-module-docs extract-module-file-docs extract-file-docs - make-default-doc-env make-module-doc-env) + make-default-doc-env make-module-doc-env + get-optionals-signature) (include "doc.scm")) diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm index 3e845ca5..d2577ef0 100644 --- a/tests/lib-tests.scm +++ b/tests/lib-tests.scm @@ -15,6 +15,7 @@ (rename (chibi crypto md5-test) (run-tests run-md5-tests)) (rename (chibi crypto rsa-test) (run-tests run-rsa-tests)) (rename (chibi crypto sha2-test) (run-tests run-sha2-tests)) + (rename (chibi doc-test) (run-tests run-doc-tests)) ;;(rename (chibi filesystem-test) (run-tests run-filesystem-tests)) (rename (chibi generic-test) (run-tests run-generic-tests)) (rename (chibi io-test) (run-tests run-io-tests)) @@ -51,6 +52,7 @@ (run-srfi-95-tests) (run-srfi-99-tests) (run-base64-tests) +(run-doc-tests) (run-generic-tests) (run-io-tests) (run-iset-tests)