pollen/pollen/tag.rkt

#lang pollen/mode racket/base
(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)
  (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))]
      [_ (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.
       (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)
     (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 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 (λ)
    [(THIS (ID:id ARG:id ...) EXPR:expr ...)
     #'(THIS 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"
     ;; the srcloc of the `lambda` expression determines the srcloc of errors raised within its body
     #`(define ID
         (make-keyword-procedure
          #,(syntax/loc #'ID (lambda (kws kwargs . args)
                               (let ([elems (match args
                                              [(list* _ elems) elems]
                                              [_ #false])])
                                 (when elems
                                   (unless (and (list? elems) (andmap txexpr-element? elems))
                                     (raise-argument-error 'ID (format "elements need to be passed to tag function as individual trailing arguments (or, if you want to pass them as a single list, use `(apply ~a ···)` here instead of `(~a ···)`)" 'ID 'ID) (car elems)))))
                               (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
  (define foo2 (default-tag-function 'foo))
  (define-tag-function (foo attrs elems)
    `(foo ,(reverse attrs) ,@elems))
  (check-txexprs-equal? ◊(foo) ◊(foo2))
  (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}))