#lang racket (require sxml) (provide (all-defined-out)) ;;; Utilities ;;; ========= (define (sxml-prop-ref sxml key [dflt #f]) (define props (match sxml [(list tag (list '@ props ...) _ ...) props] [_ '()])) (match (assoc key props) [(list _ val) val] [#f dflt])) (define (sxml-onlychild sxml) (match sxml [(list tag (list '@ rest ...) child) child] [(list tag child) child] [_ (error "Not the only child!" sxml)])) (define (sxml-body sxml) (match sxml [(list tag (list '@ rest ...) body ...) body] [(list tag body ...) body])) (define (record-ref record key) (match record [(list tag pairs ...) (assoc key pairs)])) (define (record-ref-onlychild record key) (match (record-ref record key) [#f #f] [result (sxml-onlychild result)])) ;; Replaces key with value (keeping position) if present, ;; otherwise appends to the end. (define (record-set record key val) (define replaced? #f) (match record [(list tag children ...) (define new-record-children (reverse (for/fold ([new-children '()]) ([child children]) (if (and (equal? (car child) key) (not replaced?)) (begin (set! replaced? #t) (cons (list key val) new-children)) (cons child new-children))))) (unless replaced? (set! new-record-children (append new-record-children (list (list key val))))) (cons tag new-record-children)])) (define (record-delete record key) (match record [(list tag children ...) (cons 'record (filter (lambda (child) (not (equal? (car child) key))) children))]))