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
trivial/private/common
typed/racket/base
syntax/parse
racket/sequence))
syntax/parse))
;; =============================================================================
(begin-for-syntax
(define-syntax-class/predicate string/expanded string?)
(define-syntax-class string/format
#:attributes (expanded type*)
(pattern e:string/expanded
#:with maybe-type* (template->type* #'e.expanded)
#:when (syntax-e #'maybe-type*)
#:attr type* #'maybe-type*
#:attr expanded #'e.expanded))
;; Count the number of format escapes in a string.
;; Returns a list of optional types (to be spliced into the source code).
;; Example: If result is '(#f Integer), then
;; - The format string expects 2 arguments
;; - First argument has no type constraints, second must be an Integer
(define (format-parser stx)
(define str (if (string? (syntax-e stx)) (syntax-e stx) (quoted-stx-value? stx)))
(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.
;; Returns a list of optional types (to be spliced into the source code).
;; Example: If result is '(#f Integer), then
;; - The format string expects 2 arguments
;; - First argument has no type constraints, second must be an Integer
;; (: template->type (->* [Syntax] (Listof (U #f Syntax))))
(define-for-syntax (template->type* stx)
(define str (syntax-e stx))
(unless (string? str) (error 'template->type "Internal error: ~a" 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)])))
(define-syntax format: (make-alias #'format
(lambda (stx) (syntax-parse stx
[(_ fmt:string/format arg* ...)
;; -- 1. Parse expected types from the template
#:when (let ([num-expected (length (syntax-e #'fmt.evidence))]
[num-given (length (syntax-e #'(arg* ...)))])
(unless (= num-expected num-given)
(apply raise-arity-error
'format:
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.evidence))])
(if (syntax-e t) (quasisyntax/loc stx (ann #,a #,t)) a))
(syntax/loc stx (format fmt.expanded arg+* ...))]
[_ #f]))))
(define-syntax printf: (make-alias #'printf
(lambda (stx) (syntax-parse stx
[(_ arg* ...)
(syntax/loc stx (display (format: arg* ...)))]
[_ #f]))))