You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
107 lines
5.5 KiB
Racket
107 lines
5.5 KiB
Racket
#lang pollen/mode racket/base
|
|
(require (for-syntax racket/base syntax/parse))
|
|
(require 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 (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)])))
|
|
|
|
|
|
(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)
|
|
;; Three possible sources of attrs:
|
|
;; 1) normal attrs, in a list at the front of the args
|
|
(let*-values ([(leading-attrs xs) (parse-leading-attrs xs)]
|
|
;; 2) colon attrs, using special 'key: "value" syntax, also at the front of the args
|
|
[(colon-attrs xs) (parse-colon-attrs xs)]
|
|
;; 3) keyword attrs
|
|
[(kw-attrs) (parse-kw-attrs (append outer-kws inner-kws) (append outer-kw-args inner-kw-args))])
|
|
;; 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)))))))
|
|
|
|
|
|
(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)))))
|
|
|
|
(define make-default-tag-function default-tag-function) ; bw compat
|
|
|
|
|
|
(module+ test
|
|
(require rackunit 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"))))
|
|
(check-txexprs-equal? (outerdiv #:class "inner") '(div ((class "outer") (style "outer") (class "inner"))))
|
|
(check-txexprs-equal? (outerdiv #:class "inner" "foo") '(div ((class "outer") (style "outer") (class "inner")) "foo"))
|
|
(check-txexprs-equal? (outerdiv #:field "greens" #:id "shazbot" "foo") '(div ((class "outer") (style "outer") (field "greens") (id "shazbot")) "foo"))
|
|
(check-txexprs-equal? (outerdiv 'id: "shazbot" "foo") '(div ((class "outer") (style "outer") (id "shazbot")) "foo"))
|
|
(check-txexprs-equal? (outerdiv '((id "shazbot")) "foo") '(div ((class "outer") (style "outer") (id "shazbot")) "foo"))
|
|
(check-txexprs-equal? (outerdiv 'id: "shazbot" 'class: "inner" "foo") '(div ((class "outer") (style "outer") (id "shazbot") (class "inner")) "foo"))
|
|
;; (outerdiv 'id: "shazbot" '((class "inner")) "foo") won't work because colon attrs supplant conventional attrs (docs concur)
|
|
(check-txexprs-equal? (outerdiv 'id: "shazbot" #:class "inner" "foo") '(div ((class "outer") (style "outer") (class "inner") (id "shazbot")) "foo")))
|
|
|
|
|
|
(define-syntax (define-tag-function stx)
|
|
(syntax-parse stx
|
|
#:literals (λ)
|
|
[(_ (ID:id ARG:id ...) EXPR:expr ...)
|
|
#'(define-tag-function ID (λ (ARG ...) EXPR ...))]
|
|
[(_ ID:id (λ (ATTRS:id ELEMS:id ARG:id ...) EXPR:expr ...))
|
|
#:fail-when (> (length (syntax->list #'(ARG ...))) 0) "tag function must have exactly 2 positional arguments"
|
|
#:fail-when (check-duplicate-identifier (list #'ATTRS #'ELEMS)) "duplicate variable name"
|
|
#:fail-when (null? (syntax->list #'(EXPR ...))) "body of definition cannot be empty"
|
|
#'(define ID
|
|
(make-keyword-procedure
|
|
(λ (kws kwargs . args)
|
|
(define tx-proc (keyword-apply default-tag-function kws kwargs (list 'ID)))
|
|
(define tx (apply tx-proc args))
|
|
(define-values (_ ATTRS ELEMS) (txexpr->values tx))
|
|
EXPR ...)))]))
|
|
|
|
|
|
(module+ test
|
|
(require rackunit)
|
|
(define foo2 (default-tag-function 'foo))
|
|
|
|
(define-tag-function (foo attrs elems)
|
|
`(foo ,(reverse attrs) ,@elems))
|
|
(check-txexprs-equal? ◊foo[#:zim "zam"]{hello} ◊foo2[#:zim "zam"]{hello})
|
|
(check-txexprs-equal? ◊foo[#:ding "dong" '((zim "zam"))]{hello} ◊foo2[#:ding "dong" '((zim "zam"))]{hello})
|
|
(check-txexprs-equal? ◊foo['zim: "zam" #:ding "dong" ]{hello} ◊foo2['zim: "zam" #:ding "dong" ]{hello})
|
|
|
|
(define-tag-function foolam (λ (attrs elems)
|
|
`(foo ,(reverse attrs) ,@elems)))
|
|
(check-txexprs-equal? ◊foolam[#:zim "zam"]{hello} ◊foo2[#:zim "zam"]{hello})
|
|
(check-txexprs-equal? ◊foolam[#:ding "dong" '((zim "zam"))]{hello} ◊foo2[#:ding "dong" '((zim "zam"))]{hello})
|
|
(check-txexprs-equal? ◊foolam['zim: "zam" #:ding "dong" ]{hello} ◊foo2['zim: "zam" #:ding "dong" ]{hello})) |