feat: support #:auto-value for defparam and defthing

Manually specifying `#:value` could be cumbersome. An example is `html-empty-tags` from the `xml` collection, which is a list of more than 10 symbols. It is also error-prone, and could be out-of-sync from the actual value. This PR adds a support for `#:auto-value` in `defparam` and `defthing` to automatically query the value from the `for-label` binding. The original idea of this PR is from racket/racket#4807. Thanks to @LiberalArtist who recommended an implementation strategy, and @rocketnia for feedback. .
racket · Dec 10, 2023 · 7d6181d · 7d6181d
1 parent 73df22d
commit 7d6181d
Show file tree

Hide file tree

Showing 6 changed files with 163 additions and 22 deletions.
diff --git a/scribble-doc/scribblings/scribble/manual.scrbl b/scribble-doc/scribblings/scribble/manual.scrbl
@@ -2,6 +2,7 @@
 @(require scribble/manual "utils.rkt"
           (for-syntax racket/base)
           (for-label scribble/manual-struct
+                     racket/list
                      version/utils
                      syntax/quote))
 
@@ -1308,7 +1309,7 @@ Examples:
 
 @defform[(defparam maybe-link id arg-id
            contract-expr-datum
-           maybe-value
+           maybe-auto-value
            pre-flow ...)]{
 
 Like @racket[defproc], but for a parameter. The
@@ -1324,19 +1325,30 @@ Examples:
   A parameter that defines the current sandwich for operations that
   involve eating a sandwich. Default value is the empty sandwich.
 }
+
+@(require (for-label racket/base))
+
+@defparam[current-readtable v any/c #:auto-value]{
+  A parameter to hold a readtable.
+}
 }|
 @doc-render-examples[
   @defparam[#:link-target? #f
             current-sandwich sandwich sandwich? #:value empty-sandwich]{
     A parameter that defines the current sandwich for operations that
     involve eating a sandwich. Default value is the empty sandwich.
-  }]
+  }
+  @defparam[#:link-target? #f
+            current-readtable v any/c #:auto-value]{
+    A parameter to hold a readtable.
+  }
+]
 }
 
 
 @defform[(defparam* maybe-link id arg-id 
            in-contract-expr-datum out-contract-expr-datum
-           maybe-value
+           maybe-auto-value
            pre-flow ...)]{
 
 Like @racket[defparam], but with separate contracts for when the parameter is being
@@ -1346,15 +1358,15 @@ coerces values matching a more flexible contract to a more restrictive one;
 
 
 @defform[(defboolparam maybe-link id arg-id
-           maybe-value
+           maybe-auto-value
            pre-flow ...)]{
 
 Like @racket[defparam], but the contract on a parameter argument is
 @racket[any/c], and the contract on the parameter result is
 @racket[boolean?].}
 
 
-@defform/subs[(defthing options id contract-expr-datum maybe-value
+@defform/subs[(defthing options id contract-expr-datum maybe-auto-value
                 pre-flow ...)
               ([options (code:line maybe-kind maybe-link maybe-id)]
                [maybe-kind code:blank
@@ -1363,8 +1375,9 @@ Like @racket[defparam], but the contract on a parameter argument is
                            (code:line #:link-target? link-target?-expr)]
                [maybe-id code:blank
                          (code:line #:id id-expr)]
-               [maybe-value code:blank
-                            (code:line #:value value-expr-datum)])]{
+               [maybe-auto-value code:blank
+                            (code:line #:value value-expr-datum)
+                            #:auto-value])]{
 
 Like @racket[defproc], but for a non-procedure binding.
 
@@ -1379,6 +1392,11 @@ If @racket[#:value value-expr-datum] is given, @racket[value-expr-datum]
 is typeset using @racket[racketblock0] and included in the documentation.
 Wide values are put on a separate line.
 
+@racket[#:auto-value] is similar to @racket[#:value value-expr-datum],
+but the value is automatically queried from the for-label binding.
+@racket[#:auto-value] can only be used when the value is marshalable
+(e.g., if the value is a struct, it must be a prefab struct of marshalable values).
+
 Examples:
 @codeblock[#:keep-lang-line? #f]|{
 #lang scribble/manual
@@ -1389,6 +1407,12 @@ Examples:
 @defthing[empty-sandwich sandwich? #:value (make-sandwich empty)]{
   The empty sandwich.
 }
+
+@(require (for-label racket/list))
+
+@defthing[empty any/c #:auto-value]{
+  The empty list.
+}
 }|
 @doc-render-examples[
   @defthing[#:link-target? #f
@@ -1398,10 +1422,15 @@ Examples:
   @defthing[#:link-target? #f
             empty-sandwich sandwich? #:value (make-sandwich empty)]{
     The empty sandwich.
-  }]
+  }
+  @defthing[#:link-target? #f
+            empty any/c #:auto-value]{
+    The empty list.
+  }
+]
 }
 
-@defform[(defthing* options ([id contract-expr-datum maybe-value] ...+)
+@defform[(defthing* options ([id contract-expr-datum maybe-auto-value] ...+)
            pre-flow ...)]{
 
 Like @racket[defthing], but for multiple non-procedure bindings.

diff --git a/scribble-lib/scribble/private/manual-proc.rkt b/scribble-lib/scribble/private/manual-proc.rkt
@@ -21,7 +21,8 @@
          racket/list
          racket/contract
          (for-syntax racket/base
-                     syntax/parse)
+                     syntax/parse
+                     "marshal.rkt")
          (for-label racket/base
                     racket/contract
                     racket/class))
@@ -140,6 +141,28 @@
    #:description "#:value keyword"
    (pattern (~optional (~seq #:value value)
                        #:defaults ([value #'no-value]))))
+
+ (define-splicing-syntax-class (autoable-value-kw name proc)
+   #:description "#:value or #:auto-value keyword"
+   (pattern (~seq #:value extracted))
+   (pattern (~seq #:auto-value)
+            #:do [(define binding-info (identifier-binding name #f))
+                  (unless (list? binding-info)
+                    (raise-syntax-error #f "not imported for-label" name))
+                  ;; the first result is from-mod, which is what we want
+                  (define mod (car binding-info))
+                  (define val (proc (dynamic-require mod (syntax-e name))))
+                  (define not-marshalable (check-marshalable val))
+                  (when not-marshalable
+                    (raise-syntax-error #f "not a marshalable value" name #f '()
+                                        (format "\n  found: ~s" not-marshalable)))]
+            ;; avoid quote if the value is self-quoting
+            #:with extracted (syntax-parse val
+                               [(xs ...) #''(xs ...)]
+                               [x:id #''x]
+                               [x:keyword #''x]
+                               [_ this-syntax]))
+   (pattern (~seq) #:with extracted #'no-value))
 
  (define-splicing-syntax-class link-target?-kw
    #:description "#:link-target? keyword"
@@ -660,23 +683,32 @@
           (= i 0))))))
     (content-thunk))))
 
+(begin-for-syntax
+  (define ((extract-parameter who id) p)
+    (unless (parameter? p)
+      (raise-syntax-error who "not a parameter" id #f '() (format "\n  got: ~s" p)))
+    (p)))
+
 (define-syntax (defparam stx)
   (syntax-parse stx
-    [(_ lt:link-target?-kw id arg contract value:value-kw desc:expr ...)
+    [(_ lt:link-target?-kw id arg contract
+        {~var value (autoable-value-kw #'id (extract-parameter 'defparam #'id))} desc:expr ...)
      #'(defproc* #:kind "parameter" #:link-target? lt.expr
-         ([(id) contract] [(id [arg contract]) void? #:value value.value]) 
+         ([(id) contract] [(id [arg contract]) void? #:value value.extracted])
          desc ...)]))
 (define-syntax (defparam* stx)
   (syntax-parse stx
-    [(_ lt:link-target?-kw id arg in-contract out-contract value:value-kw desc:expr ...)
+    [(_ lt:link-target?-kw id arg in-contract out-contract
+        {~var value (autoable-value-kw #'id (extract-parameter 'defparam* #'id))} desc:expr ...)
      #'(defproc* #:kind "parameter" #:link-target? lt.expr
-         ([(id) out-contract] [(id [arg in-contract]) void? #:value value.value])
+         ([(id) out-contract] [(id [arg in-contract]) void? #:value value.extracted])
          desc ...)]))
 (define-syntax (defboolparam stx)
   (syntax-parse stx
-    [(_ lt:link-target?-kw id arg value:value-kw desc:expr ...)
+    [(_ lt:link-target?-kw id arg
+        {~var value (autoable-value-kw #'id (extract-parameter 'defboolparam #'id))} desc:expr ...)
      #'(defproc* #:kind "parameter" #:link-target? lt.expr
-         ([(id) boolean?] [(id [arg any/c]) void? #:value value.value])
+         ([(id) boolean?] [(id [arg any/c]) void? #:value value.extracted])
          desc ...)]))
 
 (define top-align-styles (make-hash))
@@ -1067,7 +1099,7 @@
                    #:defaults ([id-expr #'#f]))
         id 
         result 
-        value:value-kw
+        {~var value (autoable-value-kw #'id values)}
         desc:expr ...)
      #'(with-togetherable-racket-variables
         ()
@@ -1078,20 +1110,24 @@
                      (list (or id-val (quote-syntax/loc id))) (list (if (identifier? id-val) (syntax-e id-val) 'id)) #f
                      (list (racketblock0 result))
                      (lambda () (list desc ...))
-                     (list (result-value value.value)))))]))
+                     (list (result-value value.extracted)))))]))
 
 (define-syntax (defthing* stx)
+  (define-syntax-class clause
+    (pattern [id result {~var value (autoable-value-kw #'id values)}]
+             #:with extracted #'value.extracted))
+
   (syntax-parse stx
-    [(_ kind:kind-kw lt:link-target?-kw ([id result value:value-kw] ...+) desc:expr ...)
+    [(_ kind:kind-kw lt:link-target?-kw (c:clause ...+) desc:expr ...)
      #'(with-togetherable-racket-variables
         ()
         ()
         (*defthing kind.kind
                    lt.expr
-                   (list (quote-syntax/loc id) ...) (list 'id ...) #f
-                   (list (racketblock0 result) ...)
+                   (list (quote-syntax/loc c.id) ...) (list 'c.id ...) #f
+                   (list (racketblock0 c.result) ...)
                    (lambda () (list desc ...))
-                   (list (result-value value.value) ...)))]))
+                   (list (result-value c.extracted) ...)))]))
 
 (define (*defthing kind link? stx-ids names form? result-contracts content-thunk
                    [result-values (map (lambda (x) #f) result-contracts)])

diff --git a/scribble-lib/scribble/private/marshal.rkt b/scribble-lib/scribble/private/marshal.rkt
@@ -0,0 +1,25 @@
+#lang racket/base
+
+(provide check-marshalable)
+
+(require racket/fixnum
+         racket/flonum
+         racket/extflonum)
+
+;; check-marshalable : any/c -> (or/c #f any/c)
+(define (check-marshalable v)
+  (let loop ([v v])
+    (cond
+      [(or (null? v) (symbol? v) (number? v) (char? v) (keyword? v)
+           (string? v) (bytes? v)
+           (regexp? v) (byte-regexp? v)
+           (fxvector? v) (flvector? v) (extflonum? v))
+       #f]
+      [(pair? v) (or (loop (car v)) (loop (cdr v)))]
+      [(box? v) (loop (unbox v))]
+      [(vector? v) (for/or ([x (in-vector v)])
+                     (loop x))]
+      [(hash? v) (for/or ([(key val) (in-hash v)])
+                   (or (loop key) (loop val)))]
+      [(prefab-struct-key v) (loop (struct->vector v))]
+      [else v])))
diff --git a/scribble-test/tests/scribble/docs/manual-ex.rkt b/scribble-test/tests/scribble/docs/manual-ex.rkt
@@ -20,3 +20,14 @@
 (struct pn (x y))
 
 (define v 10)
+
+(require racket/fixnum
+         racket/flonum)
+
+(define val:flvector (flvector 1.0 2.0))
+(define val:fxvector (fxvector 1 2))
+(define val:extflonum 1.0t0)
+(define val:kw '#:foo)
+(define val:list '(1 2 3 4))
+(define val:vector #(1 2 3 4))
+(define val:param (make-parameter 'foo))
diff --git a/scribble-test/tests/scribble/docs/manual.scrbl b/scribble-test/tests/scribble/docs/manual.scrbl
@@ -52,6 +52,9 @@ A function, again, not a link target, documented to return @racket[10] using a d
 
 @defparam[#:link-target? #f p k integer? #:value 10]{A parameter, again, with a documented default value.}
 
+@defparam[#:link-target? #f val:param k any/c #:auto-value]{A parameter with auto-value.}
+
+
 @defparam*[#:link-target? #f p k real? integer?]{A parameter, yet again.}
 
 @defparam*[#:link-target? #f p k real? integer? #:value 10]{A parameter, yet again, with a documented default value.}
@@ -71,6 +74,12 @@ A function, again, not a link target, documented to return @racket[10] using a d
 
 @defthing[#:link-target? #f v integer? #:value 12345678901234567890123456789012345678901234567890]{A thing, again, with a documented value that's too wide to fit on one line.}
 
+@defthing[#:link-target? #f val:flvector any/c #:auto-value]{Test auto-value flvector reading.}
+@defthing[#:link-target? #f val:fxvector any/c #:auto-value]{Test auto-value fxvector reading.}
+@defthing[#:link-target? #f val:extflonum any/c #:auto-value]{Test auto-value extflonum reading.}
+@defthing[#:link-target? #f val:kw any/c #:auto-value]{Test auto-value keyword reading.}
+@defthing[#:link-target? #f val:list any/c #:auto-value]{Test auto-value list reading.}
+@defthing[#:link-target? #f val:vector any/c #:auto-value]{Test auto-value vector reading.}
 
 @defstruct[pt ([x real?] [y real?])]{A structure type with extra name.}
 

diff --git a/scribble-test/tests/scribble/docs/manual.txt b/scribble-test/tests/scribble/docs/manual.txt
@@ -105,6 +105,13 @@ A parameter, again.
 
 A parameter, again, with a documented default value.
 
+(val:param) -> any/c  
+(val:param k) -> void?
+  k : any/c           
+ = 'foo               
+
+A parameter with auto-value.
+
 (p) -> integer?
 (p k) -> void? 
   k : real?    
@@ -155,6 +162,30 @@ v : integer?
 A thing, again, with a documented value that’s too wide to fit on one
 line.
 
+val:flvector : any/c = #fl(1.0 2.0)
+
+Test auto-value flvector reading.
+
+val:fxvector : any/c = #fx(1 2)
+
+Test auto-value fxvector reading.
+
+val:extflonum : any/c = 1.0t0
+
+Test auto-value extflonum reading.
+
+val:kw : any/c = '#:foo
+
+Test auto-value keyword reading.
+
+val:list : any/c = '(1 2 3 4)
+
+Test auto-value list reading.
+
+val:vector : any/c = #(1 2 3 4)
+
+Test auto-value vector reading.
+
 (struct pt (x y)                     
     #:extra-constructor-name make-pt)
   x : real?