Add documentation for lots of the "undocumented" bits

In the Guile Documenta generated documentation.

knots.scm

@@ -105,6 +105,8 @@ wait on CVAR in a fiber to implement clean shutdown on Ctrl-C:
             (sigaction SIGINT #f))))))
 
 (define (call-with-temporary-thread thunk)
+  "Run THUNK in a temporary thread and return its result to the
+calling fiber."
   (let ((channel (make-channel)))
     (call-with-new-thread
      (lambda ()

knots/backtraces.scm

@@ -32,9 +32,7 @@
             knots-exception?
             knots-exception-stack
 
-            print-backtrace-and-exception/knots
-
-            classify-stack-situation))
+            print-backtrace-and-exception/knots))
 
 (define &knots-exception
   (make-exception-type '&knots-exception
@@ -43,14 +41,20 @@
 
 (define make-knots-exception
   (record-constructor &knots-exception))
+(set-procedure-property! make-knots-exception 'documentation
+  "Construct a @code{&knots-exception} with the given stack.")
 
 (define knots-exception?
   (exception-predicate &knots-exception))
+(set-procedure-property! knots-exception? 'documentation
+  "Return @code{#t} if OBJ is a @code{&knots-exception}.")
 
 (define knots-exception-stack
   (exception-accessor
    &knots-exception
    (record-accessor &knots-exception 'stack)))
+(set-procedure-property! knots-exception-stack 'documentation
+  "Return the stack from a @code{&knots-exception}.")
 
 (define (backtrace-debug-mode?)
   (let ((val (getenv "KNOTS_BACKTRACE_DEBUG")))
@@ -224,6 +228,34 @@
 (define* (print-backtrace-and-exception/knots
           exn
           #:key (port (current-error-port)))
+  "Print the backtrace and exception information from EXN to PORT. This
+procedure captures the stack, so should be run before the stack is
+unwound, so using @code{with-exception-handler} without
+@code{#:unwind? #t}, the exception may need to then be re-raised and
+handled in an outer exception handler.
+
+@example
+(with-exception-handler
+    (lambda (exn)
+      ;; Recover from the exception
+      #f)
+  (lambda ()
+    (with-exception-handler
+        (lambda (exn)
+          (print-backtrace-and-exception/knots exn)
+          (raise-exception exn))
+      (lambda ()
+        (do-things))))
+  #:unwind? #t)
+@end example
+
+It's important to use @code{print-backtrace-and-exception/knots} for
+displaying backtraces involving functionality from Guile Knots, since
+the stack involved is potentially split across several fibers. The
+stacks involved are attached to the exception, and this procedure
+extracts this information out and assembles a backtrace including all
+the code involved.
+"
   (define (get-string out stack)
     (let* ((stack-vector (stack->vector stack))
            (knots-stack-vectors

knots/parallelism.scm

@@ -326,6 +326,10 @@ write directly to @code{process-channel}."
   (make-parallelism-limiter-record resource-pool)
   parallelism-limiter?
   (resource-pool     parallelism-limiter-resource-pool))
+(set-procedure-property!
+ (macro-transformer (module-ref (current-module) 'parallelism-limiter?))
+ 'documentation
+ "Return @code{#t} if OBJ is a @code{<parallelism-limiter>}.")
 
 (define* (make-parallelism-limiter limit #:key (name "unnamed"))
   "Return a parallelism limiter that allows at most LIMIT concurrent
@@ -340,6 +344,7 @@ time.  Further fibers block until a slot becomes free.
     #:name name)))
 
 (define (destroy-parallelism-limiter parallelism-limiter)
+  "Destroy PARALLELISM-LIMITER, releasing its underlying resource pool."
   (destroy-resource-pool
    (parallelism-limiter-resource-pool
     parallelism-limiter)))
@@ -354,6 +359,8 @@ currently available."
       (thunk))))
 
 (define-syntax-rule (with-parallelism-limiter parallelism-limiter exp ...)
+  "Evaluate EXP ... while holding a slot from PARALLELISM-LIMITER.
+Syntactic sugar around @code{call-with-parallelism-limiter}."
   (call-with-parallelism-limiter
       parallelism-limiter
     (lambda () exp ...)))

knots/promise.scm

@@ -39,6 +39,10 @@
   (thunk                fibers-promise-thunk)
   (values-box           fibers-promise-values-box)
   (evaluated-condition  fibers-promise-evaluated-condition))
+(set-procedure-property!
+ (macro-transformer (module-ref (current-module) 'fibers-promise?))
+ 'documentation
+ "Return @code{#t} if OBJ is a @code{<fibers-promise>}.")
 
 (define (fibers-delay thunk)
   "Return a new fiber-aware promise that will evaluate THUNK when

knots/resource-pool.scm

@@ -86,6 +86,22 @@
                      set-resource-pool-channel!)
   (destroy-condition resource-pool-destroy-condition)
   (configuration     resource-pool-configuration))
+(set-procedure-property!
+ (macro-transformer (module-ref (current-module) 'resource-pool?))
+ 'documentation
+ "Return @code{#t} if OBJ is a @code{<resource-pool>}.")
+(set-procedure-property!
+ (macro-transformer (module-ref (current-module) 'resource-pool-name))
+ 'documentation
+ "Return the name of the resource pool.")
+(set-procedure-property!
+ (macro-transformer (module-ref (current-module) 'resource-pool-channel))
+ 'documentation
+ "Return the channel used by the resource pool.")
+(set-procedure-property!
+ (macro-transformer (module-ref (current-module) 'resource-pool-configuration))
+ 'documentation
+ "Return the configuration alist of the resource pool.")
 
 (set-record-type-printer!
  <resource-pool>
@@ -1277,12 +1293,16 @@ receive @code{&resource-pool-destroyed}."
   (exception-accessor
    &resource-pool-timeout
    (record-accessor &resource-pool-timeout 'pool)))
+(set-procedure-property! resource-pool-timeout-error-pool 'documentation
+  "Return the pool from a @code{&resource-pool-timeout} exception.")
 
 (define make-resource-pool-timeout-error
   (record-constructor &resource-pool-timeout))
 
 (define resource-pool-timeout-error?
   (exception-predicate &resource-pool-timeout))
+(set-procedure-property! resource-pool-timeout-error? 'documentation
+  "Return @code{#t} if OBJ is a @code{&resource-pool-timeout} exception.")
 
 (define &resource-pool-too-many-waiters
   (make-exception-type '&recource-pool-too-many-waiters
@@ -1293,17 +1313,23 @@ receive @code{&resource-pool-destroyed}."
   (exception-accessor
    &resource-pool-too-many-waiters
    (record-accessor &resource-pool-too-many-waiters 'pool)))
+(set-procedure-property! resource-pool-too-many-waiters-error-pool 'documentation
+  "Return the pool from a @code{&resource-pool-too-many-waiters} exception.")
 
 (define resource-pool-too-many-waiters-error-waiters-count
   (exception-accessor
    &resource-pool-too-many-waiters
    (record-accessor &resource-pool-too-many-waiters 'waiters-count)))
+(set-procedure-property! resource-pool-too-many-waiters-error-waiters-count 'documentation
+  "Return the waiters count from a @code{&resource-pool-too-many-waiters} exception.")
 
 (define make-resource-pool-too-many-waiters-error
   (record-constructor &resource-pool-too-many-waiters))
 
 (define resource-pool-too-many-waiters-error?
   (exception-predicate &resource-pool-too-many-waiters))
+(set-procedure-property! resource-pool-too-many-waiters-error? 'documentation
+  "Return @code{#t} if OBJ is a @code{&resource-pool-too-many-waiters} exception.")
 
 (define &resource-pool-destroyed
   (make-exception-type '&recource-pool-destroyed
@@ -1314,12 +1340,16 @@ receive @code{&resource-pool-destroyed}."
   (exception-accessor
    &resource-pool-destroyed
    (record-accessor &resource-pool-destroyed 'pool)))
+(set-procedure-property! resource-pool-destroyed-error-pool 'documentation
+  "Return the pool from a @code{&resource-pool-destroyed} exception.")
 
 (define make-resource-pool-destroyed-error
   (record-constructor &resource-pool-destroyed))
 
 (define resource-pool-destroyed-error?
   (exception-predicate &resource-pool-destroyed))
+(set-procedure-property! resource-pool-destroyed-error? 'documentation
+  "Return @code{#t} if OBJ is a @code{&resource-pool-destroyed} exception.")
 
 (define &resource-pool-destroy-resource
   (make-exception-type '&recource-pool-destroy-resource
@@ -1328,9 +1358,13 @@ receive @code{&resource-pool-destroyed}."
 
 (define make-resource-pool-destroy-resource-exception
   (record-constructor &resource-pool-destroy-resource))
+(set-procedure-property! make-resource-pool-destroy-resource-exception 'documentation
+  "Construct a @code{&resource-pool-destroy-resource} exception.")
 
 (define resource-pool-destroy-resource-exception?
   (exception-predicate &resource-pool-destroy-resource))
+(set-procedure-property! resource-pool-destroy-resource-exception? 'documentation
+  "Return @code{#t} if OBJ is a @code{&resource-pool-destroy-resource} exception.")
 
 (define resource-pool-default-timeout-handler
   (make-parameter #f))
@@ -1467,6 +1501,8 @@ available.  Return the resource once PROC has returned."
            (apply values vals)))))))
 
 (define-syntax-rule (with-resource-from-pool pool resource exp ...)
+  "Evaluate EXP ... with RESOURCE bound to a resource checked out from
+POOL.  Syntactic sugar around @code{call-with-resource-from-pool}."
   (call-with-resource-from-pool
       pool
     (lambda (resource) exp ...)))

knots/thread-pool.scm

@@ -160,6 +160,14 @@ from there, or #f if that would be an empty string."
   thread-pool?
   (resource-pool       thread-pool-resource-pool)
   (arguments-parameter thread-pool-arguments-parameter-accessor))
+(set-procedure-property!
+ (macro-transformer (module-ref (current-module) 'thread-pool?))
+ 'documentation
+ "Return @code{#t} if OBJ is a @code{<thread-pool>}.")
+(set-procedure-property!
+ (macro-transformer (module-ref (current-module) 'thread-pool-resource-pool))
+ 'documentation
+ "Return the underlying resource pool of the thread pool.")
 
 (define-record-type <fixed-size-thread-pool>
   (fixed-size-thread-pool channel arguments-parameter current-procedures
@@ -170,15 +178,29 @@ from there, or #f if that would be an empty string."
   (current-procedures  fixed-size-thread-pool-current-procedures)
   (default-checkout-timeout fixed-size-thread-pool-default-checkout-timeout)
   (threads             fixed-size-thread-pool-threads))
+(set-procedure-property!
+ (macro-transformer (module-ref (current-module) 'fixed-size-thread-pool?))
+ 'documentation
+ "Return @code{#t} if OBJ is a @code{<fixed-size-thread-pool>}.")
+(set-procedure-property!
+ (macro-transformer (module-ref (current-module) 'fixed-size-thread-pool-channel))
+ 'documentation
+ "Return the channel of the fixed-size thread pool.")
+(set-procedure-property!
+ (macro-transformer (module-ref (current-module) 'fixed-size-thread-pool-current-procedures))
+ 'documentation
+ "Return the current procedures vector of the fixed-size thread pool.")
 
 ;; Since both thread pool records have this field, use a procedure
 ;; than handles the appropriate accessor
 (define (thread-pool-arguments-parameter pool)
+  "Return the arguments parameter for POOL, dispatching on pool type."
   (if (fixed-size-thread-pool? pool)
       (fixed-size-thread-pool-arguments-parameter pool)
       (thread-pool-arguments-parameter-accessor pool)))
 
 (define (thread-pool-default-checkout-timeout pool)
+  "Return the default checkout timeout for POOL."
   (if (fixed-size-thread-pool? pool)
       (fixed-size-thread-pool-default-checkout-timeout pool)
       (assq-ref (resource-pool-configuration
@@ -197,9 +219,13 @@ from there, or #f if that would be an empty string."
   (exception-accessor
    &thread-pool-timeout-error
    (record-accessor &thread-pool-timeout-error 'pool)))
+(set-procedure-property! thread-pool-timeout-error-pool 'documentation
+  "Return the pool from a @code{&thread-pool-timeout-error} exception.")
 
 (define thread-pool-timeout-error?
   (exception-predicate &thread-pool-timeout-error))
+(set-procedure-property! thread-pool-timeout-error? 'documentation
+  "Return @code{#t} if OBJ is a @code{&thread-pool-timeout-error} exception.")
 
 (define* (make-fixed-size-thread-pool size
                                       #:key

knots/timeout.scm

@@ -95,6 +95,8 @@ If THUNK raises an exception it is re-raised in the calling fiber."
 
 (define port-timeout-error?
   (exception-predicate &port-timeout-error))
+(set-procedure-property! port-timeout-error? 'documentation
+  "Return @code{#t} if OBJ is a @code{&port-timeout-error}.")
 
 (define &port-read-timeout-error
   (make-exception-type '&port-read-timeout-error
@@ -106,6 +108,8 @@ If THUNK raises an exception it is re-raised in the calling fiber."
 
 (define port-read-timeout-error?
   (exception-predicate &port-read-timeout-error))
+(set-procedure-property! port-read-timeout-error? 'documentation
+  "Return @code{#t} if OBJ is a @code{&port-read-timeout-error}.")
 
 (define &port-write-timeout-error
   (make-exception-type '&port-write-timeout-error
@@ -117,6 +121,8 @@ If THUNK raises an exception it is re-raised in the calling fiber."
 
 (define port-write-timeout-error?
   (exception-predicate &port-write-timeout-error))
+(set-procedure-property! port-write-timeout-error? 'documentation
+  "Return @code{#t} if OBJ is a @code{&port-write-timeout-error}.")
 
 (define (readable? port)
   "Test if PORT is readable."

knots/web-server.scm

@@ -141,23 +141,29 @@ closes PORT, unless KEEP-ALIVE? is true."
 
 (define request-body-ended-prematurely-error?
   (exception-predicate &request-body-ended-prematurely))
+(set-procedure-property! request-body-ended-prematurely-error? 'documentation
+  "Return @code{#t} if OBJ is a @code{&request-body-ended-prematurely} exception.")
 
-(define (request-body-port/knots r)
+(define (request-body-port/knots request)
+  "Return an input port for reading the body of request REQUEST.
+Handles chunked transfer encoding."
   (cond
-   ((member '(chunked) (request-transfer-encoding r))
-    (make-chunked-input-port (request-port r)
+   ((member '(chunked) (request-transfer-encoding request))
+    (make-chunked-input-port (request-port request)
                              #:keep-alive? #t))
    (else
     (let ((content-length
-           (request-content-length r)))
+           (request-content-length request)))
       (make-delimited-input-port
-       (request-port r)
+       (request-port request)
        content-length
        (lambda (bytes-read)
          (raise-exception
           (make-request-body-ended-prematurely-error bytes-read))))))))
 
 (define (read-request-body/knots r)
+  "Read and return the full body of request R as a bytevector.
+Handles chunked transfer encoding."
   (cond
    ((member '(chunked) (request-transfer-encoding r))
     (get-bytevector-all
@@ -299,6 +305,8 @@ on the procedure being called at any particular time."
   #f)
 
 (define (default-write-response-exception-handler exn request)
+  "Default handler for exceptions raised while writing an HTTP response.
+Logs the error for REQUEST to the current error port."
   (if (and (exception-with-origin? exn)
            (string=? (exception-origin exn)
                      "fport_write"))
@@ -528,6 +536,18 @@ on the procedure being called at any particular time."
   web-server?
   (socket    web-server-socket)
   (port      web-server-port))
+(set-procedure-property!
+ (macro-transformer (module-ref (current-module) 'web-server?))
+ 'documentation
+ "Return @code{#t} if OBJ is a @code{<web-server>}.")
+(set-procedure-property!
+ (macro-transformer (module-ref (current-module) 'web-server-socket))
+ 'documentation
+ "Return the socket of the web server.")
+(set-procedure-property!
+ (macro-transformer (module-ref (current-module) 'web-server-port))
+ 'documentation
+ "Return the port number of the web server.")
 
 (define* (run-knots-web-server handler #:key
                                (host #f)

tests/backtraces/stack-situation-fibers.scm

@@ -11,7 +11,8 @@
            (print-backtrace-and-exception/knots exn)
            (simple-format/knots #t
                                 "situation: ~A\n"
-                                (classify-stack-situation
+                                ((@@ (knots backtraces)
+                                     classify-stack-situation)
                                  (stack->vector stack))))
          (primitive-exit 0))
      (lambda ()

tests/backtraces/stack-situation-script.scm

@@ -8,7 +8,8 @@
         (print-backtrace-and-exception/knots exn)
         (simple-format/knots #t
                              "situation: ~A\n"
-                             (classify-stack-situation
+                             ((@@ (knots backtraces)
+                                  classify-stack-situation)
                               (stack->vector stack))))
       (primitive-exit 0))
   (lambda ()

tests/backtraces/stack-situation-unknown.scm

@@ -9,7 +9,9 @@
      (lambda (exn)
        (let* ((stack (make-stack #t))
               (stack-classification
-               (classify-stack-situation (stack->vector stack))))
+               ((@@ (knots backtraces)
+                    classify-stack-situation)
+                (stack->vector stack))))
          (print-backtrace-and-exception/knots exn)
          (simple-format/knots #t "situation: ~A\n" stack-classification)
          (primitive-exit 0)))