Fixing doc inference via procedure analysis.

Show a basic header even when inference fails.

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)
+(define (get-procedure-signature mod id proc)
-  (cond ((and (procedure? proc) (procedure-signature proc)) => list)
+  (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))
+     (get-value-signature mod id proc name body))
-    (('begin body0 ... body) (get-value-signature proc name body))
+    (('begin body0 ... body) (get-value-signature mod id proc name body))
-    (else (get-procedure-signature proc))))
+    (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 (<file> . <line>) macro source or
   ;; (<offset> <file . <line>>) 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
+                          (and (not (memq id ids)) (assq id all-defs)))
-                                      (('define (name . x) . y) name)
+                     (let ((sigs (if (and (null? sigs) id)
-                                      (((or 'define 'define-syntax) name . x)
+                                     (list id)
-                                       name)
+                                     sigs)))
-                                      (((or 'define-c 'define-c-const)
+                       (lp '() '() (append (insert-signature cur #f sigs) res)
-                                        t (name . x) . y)
+                           ids depth line)))
-                                       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))
                     (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)
+           (reverse
-                                  (extract-file-docs x defs strict? 'module))
+            (append-map (lambda (x)
-                                (module-include-library-declarations mod)))
+                          (extract-file-docs mod x defs strict? 'module))
-           (reverse (append-map (lambda (x) (extract-file-docs x defs strict?))
+                        (module-include-library-declarations mod)))
-                                (module-includes mod)))
+           (reverse
-           (reverse (append-map (lambda (x) (extract-file-docs x defs strict? 'ffi))
+            (append-map (lambda (x) (extract-file-docs mod x defs strict?))
-                                (module-shared-includes mod))))))))
+                        (module-includes mod)))
+           (reverse
+            (append-map (lambda (x) (extract-file-docs mod x defs strict? 'ffi))
+                        (module-shared-includes mod))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

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))
+                (cond
-                         (eq? (procedure-name x) (ref-name (set-var (car ls)))))
+                 ((and (set? (car ls))
-                    (set-value (car ls))
+                       (eq? name (ref-name (set-var (car ls)))))
-                    (lp (cdr ls))))))))
+                  (set-value (car ls)))
+                 ((seq? (car ls))
+                  (lp (append (seq-ls (car ls)) (cdr ls))))
+                 (else
+                  (lp (cdr ls)))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; finding all available modules

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))))))))