[format] much improved implementation

format.rkt

@@ -22,63 +22,20 @@
   (for-syntax
     trivial/private/common
     typed/racket/base
-    syntax/parse
+    syntax/parse))
-    racket/sequence))
 
 ;; =============================================================================
 
 (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-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
@@ -110,4 +67,42 @@
             (raise-user-error "format: unrecognized pattern string '~~~c'"
               (string-ref str (+ i 1)))])]
          [else
-      (loop (+ i 1) acc)])))
+          (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: (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]))))