diff --git a/pollen/private/ts.rktd b/pollen/private/ts.rktd index d42550a..9050ff3 100644 --- a/pollen/private/ts.rktd +++ b/pollen/private/ts.rktd @@ -1 +1 @@ -1540858360 +1540858363 diff --git a/pollen/tag.rkt b/pollen/tag.rkt index b0fa476..68eeb2b 100644 --- a/pollen/tag.rkt +++ b/pollen/tag.rkt @@ -1,32 +1,37 @@ #lang pollen/mode racket/base -(require (for-syntax racket/base syntax/parse)) -(require txexpr/base racket/string racket/match) +(require (for-syntax + racket/base + syntax/parse) + txexpr/base + racket/string + racket/match) (provide default-tag-function make-default-tag-function define-tag-function) - (define (parse-leading-attrs xs) (match xs [(cons (? txexpr-attrs? leading-attrs) tail) (values leading-attrs tail)] [else (values null xs)])) +(define (colon-attr-name? x) + (match x + [(? symbol?) + (=> resume) + (match (symbol->string x) + [(regexp #rx".*?(?=:$)" (cons res _)) (string->symbol res)] + [_ (resume)])] + [_ #false])) (define (parse-colon-attrs xs) - (define (colon-attr-name? x) - (and (symbol? x) - (let ([result (regexp-match #rx".*?(?=:$)" (symbol->string x))]) - (and (pair? result) (string->symbol (car result)))))) (let parse-next ([xs xs][colon-attrs empty]) (match xs [(list* (? colon-attr-name? name) (? string? val) xs) (parse-next xs (cons (list (colon-attr-name? name) val) colon-attrs))] - [else (values colon-attrs xs)]))) - + [_ (values colon-attrs xs)]))) (define (parse-kw-attrs kw-symbols-in kw-args) (define kw-symbols (map (λ (kw) (string->symbol (string-trim (keyword->string kw) "#:"))) kw-symbols-in)) (map list kw-symbols kw-args)) - (define (make-one-tag-function outer-kws outer-kw-args id) (make-keyword-procedure (λ (inner-kws inner-kw-args . xs) @@ -40,25 +45,23 @@ ;; construct the xexpr result "manually" (i.e., not with `make-txexpr` because it may not be a legit txexpr for now ;; (but it may become one through further processing, so no need to be finicky) ;; however, don't show empty attrs. - (define attrs (append kw-attrs colon-attrs leading-attrs)) - (cons id (if (null? attrs) - xs - (cons attrs xs))))))) - + (cons id (match (append kw-attrs colon-attrs leading-attrs) + [(== empty) xs] + [attrs (cons attrs xs)])))))) (define default-tag-function (make-keyword-procedure - (λ (outer-kws outer-kw-args . ids) - (let ([tag-proc (apply compose1 (for/list ([id (in-list ids)]) - (make-one-tag-function outer-kws outer-kw-args id)))] - [tag-proc-name (string->symbol (format "pollen-tag:~a" (string-join (map symbol->string ids) "+")))]) - (procedure-rename tag-proc tag-proc-name))))) + (λ (outer-kws outer-kw-args . ids) + (define tag-proc (apply compose1 (for/list ([id (in-list ids)]) + (make-one-tag-function outer-kws outer-kw-args id)))) + (define tag-proc-name (string->symbol (format "pollen-tag:~a" (string-join (map symbol->string ids) "+")))) + (procedure-rename tag-proc tag-proc-name)))) (define make-default-tag-function default-tag-function) ; bw compat (module+ test - (require rackunit txexpr/check) + (require txexpr/check) (define outerdiv (default-tag-function 'div #:class "outer" #:style "outer")) (check-txexprs-equal? (outerdiv "foo") '(div ((class "outer") (style "outer")) "foo")) (check-txexprs-equal? (outerdiv) '(div ((class "outer") (style "outer")))) @@ -91,7 +94,7 @@ (module+ test - (require rackunit) + (require) (define foo2 (default-tag-function 'foo)) (define-tag-function (foo attrs elems)