suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
inspired by #2624 by @lexi-lambda
This commit is contained in:
Ryan Culpepper 2019-04-29 18:44:43 +02:00
parent 3907f35d1d
commit 375a4837c7
2 changed files with 70 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
pkgs/racket-doc/scribblings/reference/syntax-util.scrbl
View File

@ -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?]

61
racket/collects/racket/syntax.rkt
View File

@ -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)]
[str (apply format fmt args)]
[sym (string->symbol str)])
(datum->syntax lctx sym src props cert)))
(define arg-strs (map (lambda (a) (->string a 'format-id)) args))
(define str (apply format fmt arg-strs))
(define id (datum->syntax lctx (string->symbol str) src props))
(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]
[(identifier? x) (syntax-e x)]
[(symbol? x) (symbol->string x)]
[(identifier? x) (symbol->string (syntax-e x))]
[(keyword? x) (keyword->string x)]
[(number? x) x]
[(char? x) x]
[(number? x) (number->string x)]
[(char? x) (string x)]
[else (raise-argument-error err
"(or/c string? symbol? identifier? keyword? char? number?)"
x)]))