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

[format] much improved implementation

Browse Source
This commit is contained in:
ben 2016-03-08 21:19:31 -05:00
parent d293a057e5
commit 59f5b165b1
1 changed files with 76 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

157
format.rkt
View File

@ -22,92 +22,87 @@
(for-syntax (for-syntax
trivial/private/common trivial/private/common
typed/racket/base typed/racket/base
syntax/parse syntax/parse))
racket/sequence))
;; ============================================================================= ;; =============================================================================
(begin-for-syntax (begin-for-syntax
(define-syntax-class/predicate string/expanded string?) ;; Count the number of format escapes in a string.
(define-syntax-class string/format ;; Returns a list of optional types (to be spliced into the source code).
#:attributes (expanded type*) ;; Example: If result is '(#f Integer), then
(pattern e:string/expanded ;; - The format string expects 2 arguments
#:with maybe-type* (template->type* #'e.expanded) ;; - First argument has no type constraints, second must be an Integer
#:when (syntax-e #'maybe-type*) (define (format-parser stx)
#:attr type* #'maybe-type* (define str (if (string? (syntax-e stx)) (syntax-e stx) (quoted-stx-value? stx)))
#:attr expanded #'e.expanded)) (cond
[(string? str)
(define last-index (- (string-length str) 1))
(let loop ([i 0] [acc '()])
(cond
[(>= i last-index)
(reverse acc)]
[(eq? #\~ (string-ref str i))
;; From fprintf docs @ http://docs.racket-lang.org/reference/Writing.html
(case (string-ref str (+ i 1))
[(#\% #\n #\~ #\space #\tab #\newline)
;; Need 0 arguments
(loop (+ i 2) acc)]
[(#\a #\A #\s #\S #\v #\V #\e #\E)
;; Need 1 argument, can be anything
(loop (+ i 2) (cons #f acc))]
[(#\.)
;; Need at most 1, can be anything
(if (and (< (+ 1 i) last-index)
(memq (string-ref str (+ i 2)) '(#\a #\A #\s #\S #\v #\V)))
(loop (+ i 3) (cons #f acc))
(loop (+ i 3) acc))]
[(#\c #\C)
;; Need 1 `char?`
(loop (+ i 2) (cons (syntax/loc stx Char) acc))]
[(#\b #\B #\o #\O #\x #\X)
;; Need 1 `exact?`
(loop (+ i 2) (cons (syntax/loc stx Exact-Number) acc))]
[else
;; Invalid format sequence
(raise-user-error "format: unrecognized pattern string '~~~c'"
(string-ref str (+ i 1)))])]
[else
(loop (+ i 1) acc)]))]
[else #f]))
(define-values (
_key
fmt?
_define
_let
) (make-value-property 'string:format format-parser))
(define-syntax-class/predicate string/format fmt?)
) )
(define-syntax format:
(syntax-parser
[(f fmt:string/format arg* ...)
;; 1. Parse expected types from the template
#:when (let ([num-expected (length (syntax-e #'fmt.type*))]
[num-given (length (syntax-e #'(arg* ...)))])
(unless (= num-expected num-given)
(apply raise-arity-error
(syntax-e #'f)
num-expected
(map syntax->datum (syntax-e #'(arg* ...))))))
;; 2. If any types left obligations, use `ann` to typecheck the args
#:with (arg+* ...)
(for/list ([a (in-list (syntax-e #'(arg* ...)))]
[t (in-list (syntax-e #'fmt.type*))])
(if (syntax-e t) (quasisyntax/loc #'f (ann #,a #,t)) a))
(syntax/loc #'f (format 'fmt.expanded arg+* ...))]
[f:id
(syntax/loc #'f format)]
[(f tmp arg* ...)
(syntax/loc #'f (format tmp arg* ...))]))
;; Short for `(displayln (format: ...))`
(define-syntax printf:
(syntax-parser
[f:id
(syntax/loc #'f printf)]
[(f arg* ...)
(syntax/loc #'f (display (format: arg* ...)))]))
;; ----------------------------------------------------------------------------- ;; -----------------------------------------------------------------------------
;; Count the number of format escapes in a string. (define-syntax format: (make-alias #'format
;; Returns a list of optional types (to be spliced into the source code). (lambda (stx) (syntax-parse stx
;; Example: If result is '(#f Integer), then [(_ fmt:string/format arg* ...)
;; - The format string expects 2 arguments ;; -- 1. Parse expected types from the template
;; - First argument has no type constraints, second must be an Integer #:when (let ([num-expected (length (syntax-e #'fmt.evidence))]
;; (: template->type (->* [Syntax] (Listof (U #f Syntax)))) [num-given (length (syntax-e #'(arg* ...)))])
(define-for-syntax (template->type* stx) (unless (= num-expected num-given)
(define str (syntax-e stx)) (apply raise-arity-error
(unless (string? str) (error 'template->type "Internal error: ~a" str)) 'format:
(define last-index (- (string-length str) 1)) num-expected
(let loop ([i 0] [acc '()]) (map syntax->datum (syntax-e #'(arg* ...))))))
(cond ;; -- 2. If any types left obligations, use `ann` to typecheck the args
[(>= i last-index) #:with (arg+* ...)
(reverse acc)] (for/list ([a (in-list (syntax-e #'(arg* ...)))]
[(eq? #\~ (string-ref str i)) [t (in-list (syntax-e #'fmt.evidence))])
;; From fprintf docs @ http://docs.racket-lang.org/reference/Writing.html (if (syntax-e t) (quasisyntax/loc stx (ann #,a #,t)) a))
(case (string-ref str (+ i 1)) (syntax/loc stx (format fmt.expanded arg+* ...))]
[(#\% #\n #\~ #\space #\tab #\newline) [_ #f]))))
;; Need 0 arguments
(loop (+ i 2) acc)] (define-syntax printf: (make-alias #'printf
[(#\a #\A #\s #\S #\v #\V #\e #\E) (lambda (stx) (syntax-parse stx
;; Need 1 argument, can be anything [(_ arg* ...)
(loop (+ i 2) (cons #f acc))] (syntax/loc stx (display (format: arg* ...)))]
[(#\.) [_ #f]))))
;; Need at most 1, can be anything
(if (and (< (+ 1 i) last-index)
(memq (string-ref str (+ i 2)) '(#\a #\A #\s #\S #\v #\V)))
(loop (+ i 3) (cons #f acc))
(loop (+ i 3) acc))]
[(#\c #\C)
;; Need 1 `char?`
(loop (+ i 2) (cons (syntax/loc stx Char) acc))]
[(#\b #\B #\o #\O #\x #\X)
;; Need 1 `exact?`
(loop (+ i 2) (cons (syntax/loc stx Exact-Number) acc))]
[else
;; Invalid format sequence
(raise-user-error "format: unrecognized pattern string '~~~c'"
(string-ref str (+ i 1)))])]
[else
(loop (+ i 1) acc)])))