format-id: add #:subs? option for sub-range-binders

inspired by #2624 by @lexi-lambda

pkgs/racket-doc/scribblings/reference/syntax-util.scrbl

@@ -19,7 +19,11 @@
                     [v (or/c string? symbol? identifier? keyword? char? number?)] ...
                     [#:source src (or/c syntax? #f) #f]
                     [#:props props (or/c syntax? #f) #f]
-                    [#:cert ignored (or/c syntax? #f) #f])
+                    [#:cert ignored (or/c syntax? #f) #f]
+                    [#:subs? subs? boolean? #f]
+                    [#:subs-intro subs-introducer
+                                  (-> syntax? syntax?)
+                                  (if (syntax-transforming?) syntax-local-introduce values)])
          identifier?]{
 
 Like @racket[format], but produces an identifier using @racket[lctx]
@@ -47,6 +51,21 @@ in the argument list are automatically converted to symbols.
 
 (Scribble doesn't show it, but the DrRacket pinpoints the location of
 the second error but not of the first.)
+
+If @racket[subs?] is @racket[#t], then a @racket['sub-range-binders]
+syntax property is added to the result that records the position of
+each identifier in the @racket[v]s. The @racket[subs-intro] procedure
+is applied to each identifier, and its result is included in the
+sub-range binder record. This property value overrides a
+@racket['sub-range-binders] property copied from @racket[props].
+
+@examples[#:eval the-eval
+(syntax-property (format-id #'here "~a/~a-~a" #'point 2 #'y #:subs? #t)
+                 'sub-range-binders)
+]
+
+@history[#:changed "7.4.0.5" @elem{Added the @racket[#:subs?] and
+@racket[#:subs-intro] arguments.}]
 }
 
 @defproc[(format-symbol [fmt string?]

racket/collects/racket/syntax.rkt

@@ -110,13 +110,17 @@
                    #:source [src #f]
                    #:props [props #f]
                    #:cert [cert #f]
+                   #:subs? [subs? #f]
+                   #:subs-intro [subs-intro (default-intro)]
                    fmt . args)
-  (define (convert x) (->atom x 'format-id))
   (check-restricted-format-string 'format-id fmt)
-  (let* ([args (map convert args)]
+  (define arg-strs (map (lambda (a) (->string a 'format-id)) args))
-         [str (apply format fmt args)]
+  (define str (apply format fmt arg-strs))
-         [sym (string->symbol str)])
+  (define id (datum->syntax lctx (string->symbol str) src props))
-    (datum->syntax lctx sym src props cert)))
+  (cond [subs?
+         (syntax-property id 'sub-range-binders
+                          (make-subs 'format-id id fmt args arg-strs subs-intro))]
+        [else id]))
 ;; Eli: This looks very *useful*, but I'd like to see it more convenient to
 ;;   "preserve everything".  Maybe add a keyword argument that when #t makes
 ;;   all the others use values lctx, and when syntax makes the others use that
@@ -128,7 +132,7 @@
 ;;   throw an error if there's more or less than 1.
 
 (define (format-symbol fmt . args)
-  (define (convert x) (->atom x 'format-symbol))
+  (define (convert x) (->string x 'format-symbol))
   (check-restricted-format-string 'format-symbol fmt)
   (let ([args (map convert args)])
     (string->symbol (apply format fmt args))))
@@ -143,13 +147,48 @@
                                    fmt)
                            "format string" fmt)))
 
-(define (->atom x err)
+(define (make-subs who id fmt args arg-strs intro)
+  (define seglens (restricted-format-string-segment-lengths fmt))
+  (for/fold ([len 0] [subs null] #:result subs) ;; len is total length so far
+            ([arg (in-list args)] [arg-str (in-list arg-strs)] [seglen (in-list seglens)])
+    (define len* (+ len seglen))
+    (values (+ len* (string-length arg-str))
+            (cond [(identifier? arg)
+                   (cons (make-subrange (intro id) (intro arg)
+                                        len* (string-length arg-str))
+                         subs)]
+                  [else subs]))))
+
+(define (make-subrange new-id old-id start-in-new-id old-id-len)
+  (vector-immutable new-id start-in-new-id old-id-len 0.5 0.5
+                    old-id 0 old-id-len 0.5 0.5))
+
+(define (restricted-format-string-segment-lengths fmt)
+  ;; Returns (list p1 p2 ...) s.t. the Nth placeholder follows pN characters
+  ;; generated from the format string since the previous placeholder.
+  ;; Example: for "~ax~~ayz~aw~a", want '(0 5 1).
+  ;; PRE: fmt is restricted-format-string.
+  (let loop ([start 0] [since-last 0])
+    (cond [(regexp-match-positions #rx"~." fmt start)
+           => (lambda (p)
+                (let ([m-start (caar p)] [m-end (cdar p)])
+                  (case (string-ref fmt (add1 m-start))
+                    [(#\a #\A)
+                     (cons (+ since-last (- m-start start)) (loop m-end 0))]
+                    [else ;; "~[^aA]" produces 1 char
+                     (loop (+ since-last (- m-start start) 1))])))]
+          [else null])))
+
+(define (default-intro)
+  (if (syntax-transforming?) syntax-local-introduce values))
+
+(define (->string x err)
   (cond [(string? x) x]
-        [(symbol? x) x]
+        [(symbol? x) (symbol->string x)]
-        [(identifier? x) (syntax-e x)]
+        [(identifier? x) (symbol->string (syntax-e x))]
         [(keyword? x) (keyword->string x)]
-        [(number? x) x]
+        [(number? x) (number->string x)]
-	[(char? x) x]
+        [(char? x) (string x)]
         [else (raise-argument-error err
                                     "(or/c string? symbol? identifier? keyword? char? number?)"
                                     x)]))