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

[format] use syntax class

Browse Source
This commit is contained in:
ben 2016-03-04 16:56:37 -05:00
parent 9f88e4c773
commit 1da1b34400
1 changed files with 30 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
format.rkt
View File

@ -20,31 +20,41 @@
(require (require
(for-syntax (for-syntax
trivial/private/common
typed/racket/base typed/racket/base
syntax/parse syntax/parse
racket/sequence)) racket/sequence))
;; ============================================================================= ;; =============================================================================
(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))
)
(define-syntax format: (define-syntax format:
(syntax-parser (syntax-parser
[(f template:str arg* ...) [(f fmt:string/format arg* ...)
;; 1. Parse expected types from the template ;; 1. Parse expected types from the template
(let* ([type* (template->type* (syntax-e #'template) #:src #'f)] #:when (let ([num-expected (length (syntax-e #'fmt.type*))]
[num-expected (length type*)] [num-given (length (syntax-e #'(arg* ...)))])
[num-given (for/sum ([a (in-syntax #'(arg* ...))]) 1)]) (unless (= num-expected num-given)
(unless (= num-expected num-given) (apply raise-arity-error
(apply raise-arity-error (syntax-e #'f)
(syntax-e #'f) num-expected
num-expected (map syntax->datum (syntax-e #'(arg* ...))))))
(for/list ([a (in-syntax #'(arg* ...))]) (syntax->datum a)))) ;; 2. If any types left obligations, use `ann` to typecheck the args
;; 2. If any types left obligations, use `ann` to typecheck the args #:with (arg+* ...)
(let ([arg+* (for/list ([a (in-syntax #'(arg* ...))]
(for/list ([a (in-syntax #'(arg* ...))] [t (in-syntax #'fmt.type*)])
[t (in-list type*)]) (if t (quasisyntax/loc #'f (ann #,a #,t)) a))
(if t (quasisyntax/loc #'f (ann #,a #,t)) a))]) (syntax/loc #'f (format 'fmt.expanded arg+* ...))]
(quasisyntax/loc #'f
(format template #,@arg+*))))]
[f:id [f:id
(syntax/loc #'f format)] (syntax/loc #'f format)]
[(f tmp arg* ...) [(f tmp arg* ...)
@ -65,8 +75,10 @@
;; Example: If result is '(#f Integer), then ;; Example: If result is '(#f Integer), then
;; - The format string expects 2 arguments ;; - The format string expects 2 arguments
;; - First argument has no type constraints, second must be an Integer ;; - First argument has no type constraints, second must be an Integer
;; (: count-format-escapes (->* [String] [#:src (U #f Syntax)] (Listof (U #f Syntax)))) ;; (: template->type (->* [Syntax] (Listof (U #f Syntax))))
(define-for-syntax (template->type* str #:src [stx #f]) (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)) (define last-index (- (string-length str) 1))
(let loop ([i 0] [acc '()]) (let loop ([i 0] [acc '()])
(cond (cond