From 89e5c7f87de1f82f291b4ceca6272c3e03f630b3 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 28 Jul 2014 23:44:49 +0900 Subject: [PATCH] Fixing doc inference via procedure analysis. Show a basic header even when inference fails. --- lib/chibi/doc.scm | 84 ++++++++++++++++++++---------------- lib/chibi/modules.scm | 15 ++++--- lib/chibi/type-inference.scm | 16 ++++--- 3 files changed, 69 insertions(+), 46 deletions(-) diff --git a/lib/chibi/doc.scm b/lib/chibi/doc.scm index 93ef6c06..06b75ccb 100644 --- a/lib/chibi/doc.scm +++ b/lib/chibi/doc.scm @@ -385,6 +385,19 @@ div#footer {padding-bottom: 50px} (or (contains? (car tree) x) (contains? (cdr tree) x))))) +(define (form-defined-name form) + (match form + (('define (name . x) . y) name) + (((or 'define 'define-syntax) name . x) + name) + (((or 'define-c 'define-c-const) + t (name . x) . y) + name) + (((or 'define-c 'define-c-const) + t name . x) + name) + (else #f))) + ;; Try to determine the names of optional parameters checking common ;; patterns. (define (get-optionals ls body) @@ -445,36 +458,38 @@ div#footer {padding-bottom: 50px} (else (list opts))))))))))))) -(define (get-procedure-signature proc) - (cond ((and (procedure? proc) (procedure-signature proc)) => list) +(define (get-procedure-signature mod id proc) + (cond ((and (procedure? proc) (procedure-signature id mod)) + => (lambda (sig) + (list (cons (or id (procedure-name proc)) (cdr sig))))) (else '()))) -(define (get-value-signature proc name value) +(define (get-value-signature mod id proc name value) (match value (('(or let let* letrec letrec*) vars body0 ... body) - (get-value-signature proc name body)) + (get-value-signature mod id proc name body)) (('lambda args . body) (list (cons name (get-optionals args body)))) ((('lambda args body0 ... body) vals ...) - (get-value-signature proc name body)) - (('begin body0 ... body) (get-value-signature proc name body)) - (else (get-procedure-signature proc)))) + (get-value-signature mod id proc name body)) + (('begin body0 ... body) (get-value-signature mod id proc name body)) + (else (get-procedure-signature mod id proc)))) ;; TODO: analyze and match on AST instead of making assumptions about ;; bindings -(define (get-signature proc source form) +(define (get-signature mod id proc source form) (match form (('define (name args ...) . body) (list (cons name args))) (('define (name . args) . body) (list (cons name (get-optionals args body)))) (('define name value) - (get-value-signature proc name value)) + (get-value-signature mod id proc name value)) (('define-syntax name ('syntax-rules () (clause . body) ...)) ;; TODO: smarter summary merging forms (map (lambda (x) (cons name (cdr x))) (filter external-clause? clause))) (else - (get-procedure-signature proc)))) + (get-procedure-signature mod id proc)))) (define (get-ffi-signatures form) (match form @@ -608,7 +623,7 @@ div#footer {padding-bottom: 50px} ;; Extract inline scribble documentation (with the ;;> prefix) from a ;; source file, associating any signatures from the provided defs when ;; available and not overridden in the docs. -(define (extract-file-docs file all-defs strict? . o) +(define (extract-file-docs mod file all-defs strict? . o) ;; extract ( . ) macro source or ;; ( >) procedure source (define (source-line source) @@ -718,6 +733,7 @@ div#footer {padding-bottom: 50px} (let* ((cur (collect)) (ids (append (get-ids cur) ids)) (form (cons op (read-to-paren in))) + (id (form-defined-name form)) (line (port-line in)) ;; find all procedures defined by form (procs (filter (lambda (x) (<= last-line (third x) line)) @@ -732,9 +748,10 @@ div#footer {padding-bottom: 50px} all-defs)) (get-ffi-signatures form))) ((= 1 (length procs)) - (get-signature (caar procs) (cdar procs) form)) + (get-signature mod id (caar procs) (cdar procs) form)) (else - (get-signature #f #f form))))) + (get-signature + mod id (and id (module-ref mod id)) #f form))))) (cond ((and strict? (or (not (pair? sigs)) (not (assq (caar sigs) defs)))) @@ -748,21 +765,12 @@ div#footer {padding-bottom: 50px} (append (insert-signature cur (caar procs) sigs) res) ids depth line)) ((and (null? procs) - (let ((id (match form - (('define (name . x) . y) name) - (((or 'define 'define-syntax) name . x) - name) - (((or 'define-c 'define-c-const) - t (name . x) . y) - name) - (((or 'define-c 'define-c-const) - t name . x) - name) - (else #f)))) - (and (not (memq id ids)) - (assq id all-defs)))) - (lp '() '() (append (insert-signature cur #f sigs) res) - ids depth line)) + (and (not (memq id ids)) (assq id all-defs))) + (let ((sigs (if (and (null? sigs) id) + (list id) + sigs))) + (lp '() '() (append (insert-signature cur #f sigs) res) + ids depth line))) (else (lp '() '() (append cur res) ids depth line)))))))))))))) @@ -792,15 +800,19 @@ div#footer {padding-bottom: 50px} (append (cond ((find-module-file (module-name->file mod-name)) - => (lambda (f) (reverse (extract-file-docs f defs strict? 'module)))) + => (lambda (f) + (reverse (extract-file-docs mod f defs strict? 'module)))) (else '())) - (reverse (append-map (lambda (x) - (extract-file-docs x defs strict? 'module)) - (module-include-library-declarations mod))) - (reverse (append-map (lambda (x) (extract-file-docs x defs strict?)) - (module-includes mod))) - (reverse (append-map (lambda (x) (extract-file-docs x defs strict? 'ffi)) - (module-shared-includes mod)))))))) + (reverse + (append-map (lambda (x) + (extract-file-docs mod x defs strict? 'module)) + (module-include-library-declarations mod))) + (reverse + (append-map (lambda (x) (extract-file-docs mod x defs strict?)) + (module-includes mod))) + (reverse + (append-map (lambda (x) (extract-file-docs mod x defs strict? 'ffi)) + (module-shared-includes mod)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/lib/chibi/modules.scm b/lib/chibi/modules.scm index 15d6ee41..0d991807 100644 --- a/lib/chibi/modules.scm +++ b/lib/chibi/modules.scm @@ -143,14 +143,19 @@ (lp2 (cdr e-ls)))))))))) (define (procedure-analysis x . o) - (let ((mod (or (and (pair? o) (car o)) (containing-module x)))) + (let ((name (if (procedure? x) (procedure-name x) x)) + (mod (or (and (pair? o) (car o)) (containing-module x)))) (and mod (let lp ((ls (module-ast (analyze-module (module-name mod))))) (and (pair? ls) - (if (and (set? (car ls)) - (eq? (procedure-name x) (ref-name (set-var (car ls))))) - (set-value (car ls)) - (lp (cdr ls)))))))) + (cond + ((and (set? (car ls)) + (eq? name (ref-name (set-var (car ls))))) + (set-value (car ls))) + ((seq? (car ls)) + (lp (append (seq-ls (car ls)) (cdr ls)))) + (else + (lp (cdr ls))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; finding all available modules diff --git a/lib/chibi/type-inference.scm b/lib/chibi/type-inference.scm index 5ee79a87..9280f912 100644 --- a/lib/chibi/type-inference.scm +++ b/lib/chibi/type-inference.scm @@ -304,7 +304,15 @@ ;;> a list whose first element is the return type and whose ;;> remaining arguments are the parameter types. -(define (procedure-signature x) +(define (procedure-signature x . o) + (define (ast-sig x) + (cond + ((lambda? x) (cdr (lambda-type x))) + ((seq? x) (ast-sig (last (seq-ls x)))) + ((and (pair? x) (lambda? (car x))) (ast-sig (lambda-body x))) + ;; ((and (pair? x) (ref? (car x)) (lambda? (cdr (ref-cell (car x))))) + ;; (ast-sig (lambda-body (cdr (ref-cell (car x)))))) + (else #f))) (cond ((opcode? x) (cdr (opcode-type x))) @@ -312,14 +320,12 @@ (procedure-signature (macro-procedure x))) (else (let lp ((count 0)) - (let ((lam (procedure-analysis x))) + (let ((lam (apply procedure-analysis x o))) (cond ((and lam (not (typed? lam)) (zero? count) (containing-module x)) => (lambda (mod) (and (type-analyze-module (car mod)) (lp (+ count 1))))) - ((lambda? lam) - (cdr (lambda-type lam))) (else - #f))))))) + (ast-sig lam))))))))