racket-svg/xml.rkt

#lang racket

(require
  (for-syntax
     racket/base
     syntax/parse))

(define (tag-start name attrs)
  (string-append
    (format "<~a" name)
    (apply
      string-append
      (map (lambda (x)
             (let ([t (car x)]
                   [v (cdr x)])
               (format " ~a=\"~a\"" t v)))
           attrs))))

(define (single-tag-end)
  "/>")

(define (tag-end name content)
  (string-append
    ">"
    (if (list? content)
      (apply string-append content)
      content)
    (format "</~a>" name)))

(define (tag name attrs content)
  (string-append
    (tag-start name attrs)
    (tag-end name content)))

(define (single-tag name attrs)
  (string-append
    (tag-start name attrs)
    (single-tag-end)))

(define-syntax (mtag stx)
  (syntax-parse stx
    [(_ name:id
        ([t:id v:expr] ...)
        content:expr ...)
     #'(tag
         (symbol->string 'name)
         (list
           (cons
             (symbol->string 't)
             (if (number? v)
                 (number->string v)
                 v)) ...)
         (apply string-append
                (flatten
                  (list content ...))))]))

(define-syntax (msingle-tag stx)
  (syntax-parse stx
    [(_ name:id
        ([t:id v:expr] ...))
     #'(single-tag
         (symbol->string 'name)
         (list
           (cons
             (symbol->string 't)
             (if (number? v)
                 (number->string v)
                 v)) ...))]))

(define-syntax (define-tag stx)
  (syntax-parse stx
    [(_ name:id)
     #'(define-syntax (name stx)
         (syntax-parse stx
           [(_ attrs:expr content:expr (... ...))
            #'(mtag name attrs content (... ...))]))]))

(define-syntax (define-single-tag stx)
  (syntax-parse stx
    [(_ name:id)
     #'(define-syntax (name stx)
         (syntax-parse stx
           [(_ attrs:expr)
            #'(msingle-tag name attrs)]))]))

(provide (all-defined-out))